From d21862ad7d80b4d007ef607a87bacf2352cec863 Mon Sep 17 00:00:00 2001 From: Simon Krajewski Date: Fri, 2 Feb 2024 17:35:42 +0100 Subject: [PATCH 01/16] remove @:enumConstructorParam --- src-json/meta.json | 7 ------- src/codegen/gencommon/normalize.ml | 2 +- src/typing/typeload.ml | 1 - 3 files changed, 1 insertion(+), 9 deletions(-) diff --git a/src-json/meta.json b/src-json/meta.json index 9df0fb365e6..8d5d7b9e1f6 100644 --- a/src-json/meta.json +++ b/src-json/meta.json @@ -295,13 +295,6 @@ "targets": ["TAbstract"], "links": ["https://haxe.org/manual/types-abstract-enum.html"] }, - { - "name": "EnumConstructorParam", - "metadata": ":enumConstructorParam", - "doc": "Used internally to annotate GADT type parameters.", - "targets": ["TClass"], - "internal": true - }, { "name": "Event", "metadata": ":event", diff --git a/src/codegen/gencommon/normalize.ml b/src/codegen/gencommon/normalize.ml index 2758423ef55..5072a609734 100644 --- a/src/codegen/gencommon/normalize.ml +++ b/src/codegen/gencommon/normalize.ml @@ -31,7 +31,7 @@ open Gencommon let rec filter_param (stack:t list) t = match t with - | TInst({ cl_kind = KTypeParameter _ } as c,_) when Meta.has Meta.EnumConstructorParam c.cl_meta -> + | TInst({ cl_kind = KTypeParameter ttp },_) when ttp.ttp_host = TPHEnumConstructor -> t_dynamic | TMono r -> (match r.tm_type with diff --git a/src/typing/typeload.ml b/src/typing/typeload.ml index 7bc27105321..bfba81c88ac 100644 --- a/src/typing/typeload.ml +++ b/src/typing/typeload.ml @@ -726,7 +726,6 @@ let rec type_type_param ctx host path p tp = let c = mk_class ctx.m.curmod (fst path @ [snd path],n) (pos tp.tp_name) (pos tp.tp_name) in c.cl_params <- type_type_params ctx host c.cl_path p tp.tp_params; c.cl_meta <- tp.Ast.tp_meta; - if host = TPHEnumConstructor then c.cl_meta <- (Meta.EnumConstructorParam,[],null_pos) :: c.cl_meta; let ttp = mk_type_param c host None None in if ctx.m.is_display_file && DisplayPosition.display_position#enclosed_in (pos tp.tp_name) then DisplayEmitter.display_type ctx ttp.ttp_type (pos tp.tp_name); From bf82b4068150669ce0d5e372443cc27830d2ea01 Mon Sep 17 00:00:00 2001 From: Simon Krajewski Date: Fri, 2 Feb 2024 17:36:45 +0100 Subject: [PATCH 02/16] remove init_class_done see if this breaks anything --- src/context/typecore.ml | 8 -------- src/typing/typeloadFields.ml | 1 - 2 files changed, 9 deletions(-) diff --git a/src/context/typecore.ml b/src/context/typecore.ml index 180b14daaf7..05e4c2f4186 100644 --- a/src/context/typecore.ml +++ b/src/context/typecore.ml @@ -560,9 +560,6 @@ let rec flush_pass ctx p where = let make_pass ctx f = f -let init_class_done ctx = - ctx.pass <- PConnectField - let enter_field_typing_pass ctx info = flush_pass ctx PConnectField info; ctx.pass <- PTypeField @@ -910,11 +907,6 @@ let debug com (path : string list) str = if List.exists (Ast.match_path false path) debug_paths then emit(); end -let init_class_done ctx = - let path = fst ctx.c.curclass.cl_path @ [snd ctx.c.curclass.cl_path] in - debug ctx.com path ("init_class_done " ^ s_type_path ctx.c.curclass.cl_path); - init_class_done ctx - let ctx_pos ctx = let inf = fst ctx.m.curmod.m_path @ [snd ctx.m.curmod.m_path]in let inf = (match snd ctx.c.curclass.cl_path with "" -> inf | n when n = snd ctx.m.curmod.m_path -> inf | n -> inf @ [n]) in diff --git a/src/typing/typeloadFields.ml b/src/typing/typeloadFields.ml index 1c335511c76..cc57c6fa140 100644 --- a/src/typing/typeloadFields.ml +++ b/src/typing/typeloadFields.ml @@ -1677,7 +1677,6 @@ let check_overloads ctx c = let finalize_class cctx = (* push delays in reverse order so they will be run in correct order *) List.iter (fun (ctx,r) -> - init_class_done ctx; (match r with | None -> () | Some r -> delay ctx PTypeField (fun() -> ignore(lazy_type r))) From ec8d6d0244e1b3239fcb6539cf126002ec8075c1 Mon Sep 17 00:00:00 2001 From: Simon Krajewski Date: Fri, 2 Feb 2024 18:33:46 +0100 Subject: [PATCH 03/16] clone for expr --- src/context/typecore.ml | 4 ++++ src/typing/functionArguments.ml | 16 ++++++++-------- src/typing/typeloadFields.ml | 14 ++++++++++---- src/typing/typer.ml | 26 +++++++++++++------------- 4 files changed, 35 insertions(+), 25 deletions(-) diff --git a/src/context/typecore.ml b/src/context/typecore.ml index 05e4c2f4186..bb37840c05d 100644 --- a/src/context/typecore.ml +++ b/src/context/typecore.ml @@ -281,6 +281,10 @@ module TyperManager = struct let f = create_ctx_f null_field in let e = create_ctx_e () in create ctx.com ctx.g ctx.m ctx.c f e PBuildClass params + + let clone_for_expr ctx = + let e = create_ctx_e () in + create ctx.com ctx.g ctx.m ctx.c ctx.f e PTypeField ctx.type_params end type field_host = diff --git a/src/typing/functionArguments.ml b/src/typing/functionArguments.ml index cba9c2add66..f7251a69ca3 100644 --- a/src/typing/functionArguments.ml +++ b/src/typing/functionArguments.ml @@ -4,7 +4,7 @@ open Type open Typecore open Error -let type_function_arg ctx t e opt p = +let type_function_arg com t e opt p = (* TODO https://github.com/HaxeFoundation/haxe/issues/8461 *) (* delay ctx PTypeField (fun() -> if ExtType.is_void (follow t) then @@ -12,9 +12,9 @@ let type_function_arg ctx t e opt p = ); *) if opt then let e = (match e with None -> Some (EConst (Ident "null"),null_pos) | _ -> e) in - ctx.t.tnull t, e + com.Common.basic.tnull t, e else - let t = match e with Some (EConst (Ident "null"),null_pos) -> ctx.t.tnull t | _ -> t in + let t = match e with Some (EConst (Ident "null"),null_pos) -> com.basic.tnull t | _ -> t in t, e let type_function_arg_value ctx t c do_display = @@ -38,7 +38,7 @@ let type_function_arg_value ctx t c do_display = loop e class function_arguments - (ctx : typer) + (com : Common.context) (type_arg : int -> bool -> type_hint option -> pos -> Type.t) (is_extern : bool) (do_display : bool) @@ -48,7 +48,7 @@ class function_arguments let with_default = let l = List.mapi (fun i ((name,pn),opt,_,t,eo) -> let t = type_arg i opt t pn in - let t,eo = type_function_arg ctx t eo opt pn in + let t,eo = type_function_arg com t eo opt pn in (name,eo,t) ) syntax in let l = match abstract_this with @@ -83,7 +83,7 @@ object(self) (* Returns the `(tvar * texpr option) list` for `tf_args`. Also checks the validity of argument names and whether or not an argument should be displayed. *) - method for_expr = match expr_repr with + method for_expr ctx = match expr_repr with | Some l -> l | None -> @@ -116,7 +116,7 @@ object(self) l (* Verifies the validity of any argument typed as `haxe.extern.Rest` and checks default values. *) - method verify_extern = + method verify_extern ctx = let rec loop is_abstract_this syntax typed = match syntax,typed with | syntax,(name,_,t) :: typed when is_abstract_this -> loop false syntax typed @@ -135,5 +135,5 @@ object(self) method bring_into_context ctx = List.iter (fun (v,_) -> ctx.f.locals <- PMap.add v.v_name v ctx.f.locals - ) self#for_expr + ) (self#for_expr ctx) end diff --git a/src/typing/typeloadFields.ml b/src/typing/typeloadFields.ml index cc57c6fa140..395e7fe5123 100644 --- a/src/typing/typeloadFields.ml +++ b/src/typing/typeloadFields.ml @@ -830,6 +830,7 @@ module TypeBinding = struct let r = make_lazy ~force:false ctx t (fun r -> (* type constant init fields (issue #1956) *) if not ctx.g.return_partial_type || (match fst e with EConst _ -> true | _ -> false) then begin + let ctx = TyperManager.clone_for_expr ctx in enter_field_typing_pass ctx ("bind_var_expression",fst ctx.c.curclass.cl_path @ [snd ctx.c.curclass.cl_path;ctx.f.curfield.cf_name]); if (Meta.has (Meta.Custom ":debug.typing") (c.cl_meta @ cf.cf_meta)) then ctx.com.print (Printf.sprintf "Typing field %s.%s\n" (s_type_path c.cl_path) cf.cf_name); let e = type_var_field ctx t e fctx.is_static fctx.is_display_field p in @@ -906,6 +907,7 @@ module TypeBinding = struct let bind_method ctx cctx fctx cf t args ret e p = let c = cctx.tclass in let bind r = + let ctx = TyperManager.clone_for_expr ctx in incr stats.s_methods_typed; if (Meta.has (Meta.Custom ":debug.typing") (c.cl_meta @ cf.cf_meta)) then ctx.com.print (Printf.sprintf "Typing method %s.%s\n" (s_type_path c.cl_path) cf.cf_name); let fmode = (match cctx.abstract with @@ -944,7 +946,7 @@ module TypeBinding = struct if v.v_name <> "_" && has_mono v.v_type then warning ctx WTemp "Uninferred function argument, please add a type-hint" v.v_pos; ) fargs; *) let tf = { - tf_args = args#for_expr; + tf_args = args#for_expr ctx; tf_type = ret; tf_expr = e; } in @@ -1261,7 +1263,7 @@ let setup_args_ret ctx cctx fctx name fd p = in if i = 0 then maybe_use_property_type cto (fun () -> match Lazy.force mk with MKSetter -> true | _ -> false) def else def() in - let args = new FunctionArguments.function_arguments ctx type_arg is_extern fctx.is_display_field abstract_this fd.f_args in + let args = new FunctionArguments.function_arguments ctx.com type_arg is_extern fctx.is_display_field abstract_this fd.f_args in args,ret let create_method (ctx,cctx,fctx) c f fd p = @@ -1415,11 +1417,15 @@ let create_method (ctx,cctx,fctx) c f fd p = if fctx.is_display_field then begin delay ctx PTypeField (fun () -> (* We never enter type_function so we're missing out on the argument processing there. Let's do it here. *) - ignore(args#for_expr) + let ctx = TyperManager.clone_for_expr ctx in + ignore(args#for_expr ctx) ); check_field_display ctx fctx c cf; end else - delay ctx PTypeField (fun () -> args#verify_extern); + delay ctx PTypeField (fun () -> + let ctx = TyperManager.clone_for_expr ctx in + args#verify_extern ctx + ); if fd.f_expr <> None then begin if fctx.is_abstract then unexpected_expression ctx.com fctx "Abstract methods may not have an expression" p else if not (fctx.is_inline || fctx.is_macro) then warning ctx WExternWithExpr "Extern non-inline function may not have an expression" p; diff --git a/src/typing/typer.ml b/src/typing/typer.ml index 13aca40a8de..4299d9d1780 100644 --- a/src/typing/typer.ml +++ b/src/typing/typer.ml @@ -1216,23 +1216,30 @@ and type_map_declaration ctx e1 el with_type p = let el = (mk (TVar (v,Some enew)) t_dynamic p) :: (List.rev el) in mk (TBlock el) tmap p -and type_local_function ctx kind f with_type p = +and type_local_function ctx_from kind f with_type p = let name,inline = match kind with FKNamed (name,inline) -> Some name,inline | _ -> None,false in - let params = TypeloadFunction.type_function_params ctx f TPHLocal (match name with None -> "localfun" | Some (n,_) -> n) p in + let params = TypeloadFunction.type_function_params ctx_from f TPHLocal (match name with None -> "localfun" | Some (n,_) -> n) p in if params <> [] then begin - if name = None then display_error ctx.com "Type parameters not supported in unnamed local functions" p; + if name = None then display_error ctx_from.com "Type parameters not supported in unnamed local functions" p; if with_type <> WithType.NoValue then raise_typing_error "Type parameters are not supported for rvalue functions" p end; let v,pname = (match name with | None -> None,p | Some (v,pn) -> Some v,pn ) in - let old_tp,old_in_loop = ctx.type_params,ctx.e.in_loop in + let curfun = match ctx_from.e.curfun with + | FunStatic -> FunStatic + | FunMemberAbstract + | FunMemberAbstractLocal -> FunMemberAbstractLocal + | _ -> FunMemberClassLocal + in + let ctx = TyperManager.clone_for_expr ctx_from in + let old_tp = ctx.type_params in ctx.type_params <- params @ ctx.type_params; if not inline then ctx.e.in_loop <- false; let rt = Typeload.load_type_hint ctx p f.f_type in let type_arg _ opt t p = Typeload.load_type_hint ~opt ctx p t in - let args = new FunctionArguments.function_arguments ctx type_arg false ctx.f.in_display None f.f_args in + let args = new FunctionArguments.function_arguments ctx.com type_arg false ctx.f.in_display None f.f_args in let targs = args#for_type in let maybe_unify_arg t1 t2 = match follow t1 with @@ -1330,17 +1337,10 @@ and type_local_function ctx kind f with_type p = if params <> [] then v.v_extra <- Some (var_extra params None); Some v ) in - let curfun = match ctx.e.curfun with - | FunStatic -> FunStatic - | FunMemberAbstract - | FunMemberAbstractLocal -> FunMemberAbstractLocal - | _ -> FunMemberClassLocal - in let e = TypeloadFunction.type_function ctx args rt curfun f.f_expr ctx.f.in_display p in ctx.type_params <- old_tp; - ctx.e.in_loop <- old_in_loop; let tf = { - tf_args = args#for_expr; + tf_args = args#for_expr ctx; tf_type = rt; tf_expr = e; } in From 2b2764ab7df4bf3fe04782774570bd49369f5976 Mon Sep 17 00:00:00 2001 From: Simon Krajewski Date: Fri, 2 Feb 2024 18:46:22 +0100 Subject: [PATCH 04/16] make ctx.pass immutable --- src/context/typecore.ml | 5 ++--- src/typing/macroContext.ml | 3 +-- src/typing/typeloadFields.ml | 8 ++++---- src/typing/typerDisplay.ml | 1 - 4 files changed, 7 insertions(+), 10 deletions(-) diff --git a/src/context/typecore.ml b/src/context/typecore.ml index bb37840c05d..c31e215d20a 100644 --- a/src/context/typecore.ml +++ b/src/context/typecore.ml @@ -171,7 +171,7 @@ and typer = { c : typer_class; f : typer_field; mutable e : typer_expr; - mutable pass : typer_pass; + pass : typer_pass; mutable type_params : type_params; mutable allow_inline : bool; mutable allow_transform : bool; @@ -565,8 +565,7 @@ let rec flush_pass ctx p where = let make_pass ctx f = f let enter_field_typing_pass ctx info = - flush_pass ctx PConnectField info; - ctx.pass <- PTypeField + flush_pass ctx PConnectField info let make_lazy ?(force=true) ctx t_proc f where = let r = ref (lazy_available t_dynamic) in diff --git a/src/typing/macroContext.ml b/src/typing/macroContext.ml index b76ddbec32c..7735fd9a051 100644 --- a/src/typing/macroContext.ml +++ b/src/typing/macroContext.ml @@ -79,7 +79,7 @@ let macro_timer com l = let typing_timer ctx need_type f = let t = Timer.timer ["typing"] in - let old = ctx.com.error_ext and oldp = ctx.pass and oldlocals = ctx.f.locals in + let old = ctx.com.error_ext and oldlocals = ctx.f.locals in let restore_report_mode = disable_report_mode ctx.com in (* disable resumable errors... unless we are in display mode (we want to reach point of completion) @@ -93,7 +93,6 @@ let typing_timer ctx need_type f = let exit() = t(); ctx.com.error_ext <- old; - ctx.pass <- oldp; ctx.f.locals <- oldlocals; restore_report_mode (); in diff --git a/src/typing/typeloadFields.ml b/src/typing/typeloadFields.ml index 395e7fe5123..8a382466d65 100644 --- a/src/typing/typeloadFields.ml +++ b/src/typing/typeloadFields.ml @@ -809,10 +809,11 @@ module TypeBinding = struct display_error ctx.com ("Redefinition of variable " ^ cf.cf_name ^ " in subclass is not allowed. Previously declared at " ^ (s_type_path csup.cl_path) ) cf.cf_name_pos end - let bind_var_expression ctx cctx fctx cf e = + let bind_var_expression ctx_f cctx fctx cf e = let c = cctx.tclass in let t = cf.cf_type in let p = cf.cf_pos in + let ctx = TyperManager.clone_for_expr ctx_f in if (has_class_flag c CInterface) then unexpected_expression ctx.com fctx "Initialization on field of interface" (pos e); cf.cf_meta <- ((Meta.Value,[e],null_pos) :: cf.cf_meta); let check_cast e = @@ -830,7 +831,6 @@ module TypeBinding = struct let r = make_lazy ~force:false ctx t (fun r -> (* type constant init fields (issue #1956) *) if not ctx.g.return_partial_type || (match fst e with EConst _ -> true | _ -> false) then begin - let ctx = TyperManager.clone_for_expr ctx in enter_field_typing_pass ctx ("bind_var_expression",fst ctx.c.curclass.cl_path @ [snd ctx.c.curclass.cl_path;ctx.f.curfield.cf_name]); if (Meta.has (Meta.Custom ":debug.typing") (c.cl_meta @ cf.cf_meta)) then ctx.com.print (Printf.sprintf "Typing field %s.%s\n" (s_type_path c.cl_path) cf.cf_name); let e = type_var_field ctx t e fctx.is_static fctx.is_display_field p in @@ -904,10 +904,10 @@ module TypeBinding = struct | Some e -> bind_var_expression ctx cctx fctx cf e - let bind_method ctx cctx fctx cf t args ret e p = + let bind_method ctx_f cctx fctx cf t args ret e p = let c = cctx.tclass in + let ctx = TyperManager.clone_for_expr ctx_f in let bind r = - let ctx = TyperManager.clone_for_expr ctx in incr stats.s_methods_typed; if (Meta.has (Meta.Custom ":debug.typing") (c.cl_meta @ cf.cf_meta)) then ctx.com.print (Printf.sprintf "Typing method %s.%s\n" (s_type_path c.cl_path) cf.cf_name); let fmode = (match cctx.abstract with diff --git a/src/typing/typerDisplay.ml b/src/typing/typerDisplay.ml index 9470e8bae60..7734c359d90 100644 --- a/src/typing/typerDisplay.ml +++ b/src/typing/typerDisplay.ml @@ -583,7 +583,6 @@ let handle_display ctx e_ast dk mode with_type = raise_toplevel ctx dk with_type (s_type_path path,p) | DisplayException(DisplayFields ({fkind = CRTypeHint} as r)) when (match fst e_ast with ENew _ -> true | _ -> false) -> let timer = Timer.timer ["display";"toplevel";"filter ctors"] in - ctx.pass <- PBuildClass; let l = List.filter (fun item -> let is_private_to_current_module mt = (* Remove the _Module nonsense from the package *) From 22d7f61ed4c7a3bfc1826c9ddf61bd1db5cf5c7f Mon Sep 17 00:00:00 2001 From: Simon Krajewski Date: Fri, 2 Feb 2024 19:00:16 +0100 Subject: [PATCH 05/16] ctx.e can be immutable too --- src/context/typecore.ml | 2 +- src/typing/typeloadFunction.ml | 3 --- 2 files changed, 1 insertion(+), 4 deletions(-) diff --git a/src/context/typecore.ml b/src/context/typecore.ml index c31e215d20a..12478ec85b3 100644 --- a/src/context/typecore.ml +++ b/src/context/typecore.ml @@ -170,7 +170,7 @@ and typer = { mutable m : typer_module; c : typer_class; f : typer_field; - mutable e : typer_expr; + e : typer_expr; pass : typer_pass; mutable type_params : type_params; mutable allow_inline : bool; diff --git a/src/typing/typeloadFunction.ml b/src/typing/typeloadFunction.ml index d3dff29cd54..9e8b073b3c6 100644 --- a/src/typing/typeloadFunction.ml +++ b/src/typing/typeloadFunction.ml @@ -28,12 +28,9 @@ open Error open FunctionArguments let save_field_state ctx = - let old_e = ctx.e in - ctx.e <- TyperManager.create_ctx_e (); let locals = ctx.f.locals in (fun () -> ctx.f.locals <- locals; - ctx.e <- old_e; ) let type_function_params ctx fd host fname p = From 2e68e40967fd2969756284e5dffdf059466191a5 Mon Sep 17 00:00:00 2001 From: Simon Krajewski Date: Fri, 2 Feb 2024 21:01:50 +0100 Subject: [PATCH 06/16] add failing test to show everyone that it's broken --- tests/misc/projects/Issue11538/M.hx | 3 +++ tests/misc/projects/Issue11538/Main.hx | 25 +++++++++++++++++++ tests/misc/projects/Issue11538/compile.hxml | 2 ++ .../projects/Issue11538/compile.hxml.stdout | 1 + 4 files changed, 31 insertions(+) create mode 100644 tests/misc/projects/Issue11538/M.hx create mode 100644 tests/misc/projects/Issue11538/Main.hx create mode 100644 tests/misc/projects/Issue11538/compile.hxml create mode 100644 tests/misc/projects/Issue11538/compile.hxml.stdout diff --git a/tests/misc/projects/Issue11538/M.hx b/tests/misc/projects/Issue11538/M.hx new file mode 100644 index 00000000000..e9d9ac1c27a --- /dev/null +++ b/tests/misc/projects/Issue11538/M.hx @@ -0,0 +1,3 @@ +class M { + static public var x:Float; +} diff --git a/tests/misc/projects/Issue11538/Main.hx b/tests/misc/projects/Issue11538/Main.hx new file mode 100644 index 00000000000..58d58e3cb93 --- /dev/null +++ b/tests/misc/projects/Issue11538/Main.hx @@ -0,0 +1,25 @@ +import haxe.macro.Context; +import haxe.macro.Expr; + +using haxe.macro.Tools; + +#if !macro +@:build(Main.build()) +#end +class Main { + #if macro + static function build():Array { + var t = Context.typeof(macro M.x); + var field = (macro class X { + static public var type = $v{t.toString()}; + }).fields[0]; + return [field]; + } + #end +} + +function main() { + #if !macro + trace(Main.type); + #end +} diff --git a/tests/misc/projects/Issue11538/compile.hxml b/tests/misc/projects/Issue11538/compile.hxml new file mode 100644 index 00000000000..b30a755894b --- /dev/null +++ b/tests/misc/projects/Issue11538/compile.hxml @@ -0,0 +1,2 @@ +--main Main +--interp \ No newline at end of file diff --git a/tests/misc/projects/Issue11538/compile.hxml.stdout b/tests/misc/projects/Issue11538/compile.hxml.stdout new file mode 100644 index 00000000000..b41a42411d0 --- /dev/null +++ b/tests/misc/projects/Issue11538/compile.hxml.stdout @@ -0,0 +1 @@ +Main.hx:23: Float \ No newline at end of file From adca629e8442777a00a4dd92a6a2a857f70066e5 Mon Sep 17 00:00:00 2001 From: Simon Krajewski Date: Fri, 2 Feb 2024 21:05:24 +0100 Subject: [PATCH 07/16] fix it --- src/typing/macroContext.ml | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/src/typing/macroContext.ml b/src/typing/macroContext.ml index 7735fd9a051..76ce2f96e70 100644 --- a/src/typing/macroContext.ml +++ b/src/typing/macroContext.ml @@ -87,9 +87,12 @@ let typing_timer ctx need_type f = (* if ctx.com.display.dms_kind = DMNone then ctx.com.error <- (fun e -> raise_error e); *) (* TODO: review this... *) ctx.com.error_ext <- (fun err -> raise_error { err with err_from_macro = true }); - if need_type && ctx.pass < PTypeField then begin + let ctx = if need_type && ctx.pass < PTypeField then begin enter_field_typing_pass ctx ("typing_timer",[] (* TODO: ? *)); - end; + TyperManager.clone_for_expr ctx + end else + ctx + in let exit() = t(); ctx.com.error_ext <- old; @@ -97,7 +100,7 @@ let typing_timer ctx need_type f = restore_report_mode (); in try - let r = f() in + let r = f ctx in exit(); r with Error err -> @@ -349,7 +352,7 @@ let make_macro_api ctx mctx p = { com_api with MacroApi.get_type = (fun s -> - typing_timer ctx false (fun() -> + typing_timer ctx false (fun ctx -> let path = parse_path s in let tp = match List.rev (fst path) with | s :: sl when String.length s > 0 && (match s.[0] with 'A'..'Z' -> true | _ -> false) -> @@ -365,10 +368,10 @@ let make_macro_api ctx mctx p = ) ); MacroApi.resolve_type = (fun t p -> - typing_timer ctx false (fun() -> Typeload.load_complex_type ctx false (t,p)) + typing_timer ctx false (fun ctx -> Typeload.load_complex_type ctx false (t,p)) ); MacroApi.resolve_complex_type = (fun t -> - typing_timer ctx false (fun() -> + typing_timer ctx false (fun ctx -> let rec load (t,_) = ((match t with | CTPath ptp -> @@ -421,20 +424,20 @@ let make_macro_api ctx mctx p = ) ); MacroApi.get_module = (fun s -> - typing_timer ctx false (fun() -> + typing_timer ctx false (fun ctx -> let path = parse_path s in let m = List.map type_of_module_type (TypeloadModule.load_module ctx path p).m_types in m ) ); MacroApi.type_expr = (fun e -> - typing_timer ctx true (fun() -> type_expr ctx e WithType.value) + typing_timer ctx true (fun ctx -> type_expr ctx e WithType.value) ); MacroApi.flush_context = (fun f -> - typing_timer ctx true f + typing_timer ctx true (fun _ -> f ()) ); MacroApi.type_patch = (fun t f s v -> - typing_timer ctx false (fun() -> + typing_timer ctx false (fun ctx -> let v = (match v with None -> None | Some s -> match ParserEntry.parse_string Grammar.parse_complex_type ctx.com.defines s null_pos raise_typing_error false with | ParseSuccess((ct,_),_,_) -> Some ct @@ -545,7 +548,7 @@ let make_macro_api ctx mctx p = end ); MacroApi.module_dependency = (fun mpath file -> - let m = typing_timer ctx false (fun() -> + let m = typing_timer ctx false (fun ctx -> let old_deps = ctx.m.curmod.m_extra.m_deps in let m = TypeloadModule.load_module ctx (parse_path mpath) p in ctx.m.curmod.m_extra.m_deps <- old_deps; @@ -557,7 +560,7 @@ let make_macro_api ctx mctx p = ctx.m.curmod ); MacroApi.cast_or_unify = (fun t e p -> - typing_timer ctx true (fun () -> + typing_timer ctx true (fun ctx -> try ignore(AbstractCast.cast_or_unify_raise ctx t e p); true From b1c6087a1041bc4a01e64820579d27b1f4ea1904 Mon Sep 17 00:00:00 2001 From: Simon Krajewski Date: Fri, 2 Feb 2024 22:08:41 +0100 Subject: [PATCH 08/16] only need g for delays --- src/context/display/displayEmitter.ml | 2 +- src/context/display/displayTexpr.ml | 2 +- src/context/display/importHandling.ml | 2 +- src/context/display/syntaxExplorer.ml | 2 +- src/context/typecore.ml | 34 +++++++++++----------- src/typing/finalization.ml | 4 +-- src/typing/functionArguments.ml | 4 +-- src/typing/generic.ml | 4 +-- src/typing/instanceBuilder.ml | 2 +- src/typing/macroContext.ml | 4 +-- src/typing/strictMeta.ml | 2 +- src/typing/typeload.ml | 16 +++++----- src/typing/typeloadCheck.ml | 40 ++++++++++++------------- src/typing/typeloadFields.ml | 42 +++++++++++++-------------- src/typing/typeloadFunction.ml | 6 ++-- src/typing/typeloadModule.ml | 34 +++++++++++----------- src/typing/typer.ml | 2 +- 17 files changed, 101 insertions(+), 101 deletions(-) diff --git a/src/context/display/displayEmitter.ml b/src/context/display/displayEmitter.ml index 58b50c7d25f..2b8e7d0fc1b 100644 --- a/src/context/display/displayEmitter.ml +++ b/src/context/display/displayEmitter.ml @@ -169,7 +169,7 @@ let check_display_metadata ctx meta = List.iter (fun e -> if display_position#enclosed_in (pos e) then begin let e = preprocess_expr ctx.com e in - delay ctx PTypeField (fun _ -> ignore(type_expr ctx e WithType.value)); + delay ctx.g PTypeField (fun _ -> ignore(type_expr ctx e WithType.value)); end ) args ) meta diff --git a/src/context/display/displayTexpr.ml b/src/context/display/displayTexpr.ml index 777ba93ef24..928ac013bbf 100644 --- a/src/context/display/displayTexpr.ml +++ b/src/context/display/displayTexpr.ml @@ -63,7 +63,7 @@ let actually_check_display_field ctx c cff p = let display_modifier = Typeload.check_field_access ctx cff in let fctx = TypeloadFields.create_field_context ctx cctx cff true display_modifier in let cf = TypeloadFields.init_field (ctx,cctx,fctx) cff in - flush_pass ctx PTypeField ("check_display_field",(fst c.cl_path @ [snd c.cl_path;fst cff.cff_name])); + flush_pass ctx.g PTypeField ("check_display_field",(fst c.cl_path @ [snd c.cl_path;fst cff.cff_name])); ignore(follow cf.cf_type) let check_display_field ctx sc c cf = diff --git a/src/context/display/importHandling.ml b/src/context/display/importHandling.ml index 69a9e9f16c3..d0ac35235ff 100644 --- a/src/context/display/importHandling.ml +++ b/src/context/display/importHandling.ml @@ -296,4 +296,4 @@ let init_using ctx path p = ctx.m.import_resolution#add (module_type_resolution mt None p) ) (List.rev types); (* delay the using since we need to resolve typedefs *) - delay_late ctx PConnectField (fun () -> ctx.m.module_using <- filter_classes types @ ctx.m.module_using) + delay_late ctx.g PConnectField (fun () -> ctx.m.module_using <- filter_classes types @ ctx.m.module_using) diff --git a/src/context/display/syntaxExplorer.ml b/src/context/display/syntaxExplorer.ml index bc6c1328cc3..2a7b2bd4978 100644 --- a/src/context/display/syntaxExplorer.ml +++ b/src/context/display/syntaxExplorer.ml @@ -177,7 +177,7 @@ let explore_uncached_modules tctx cs symbols = begin try let m = tctx.g.do_load_module tctx (cfile.c_package,module_name) null_pos in (* We have to flush immediately so we catch exceptions from weird modules *) - Typecore.flush_pass tctx Typecore.PFinal ("final",cfile.c_package @ [module_name]); + Typecore.flush_pass tctx.g Typecore.PFinal ("final",cfile.c_package @ [module_name]); m :: acc with _ -> acc diff --git a/src/context/typecore.ml b/src/context/typecore.ml index 12478ec85b3..7f88172d8bc 100644 --- a/src/context/typecore.ml +++ b/src/context/typecore.ml @@ -522,50 +522,50 @@ let is_gen_local v = match v.v_kind with | _ -> false -let delay ctx p f = +let delay g p f = let p = Obj.magic p in - let tasks = ctx.g.delayed.(p) in + let tasks = g.delayed.(p) in tasks.tasks <- f :: tasks.tasks; - if p < ctx.g.delayed_min_index then - ctx.g.delayed_min_index <- p + if p < g.delayed_min_index then + g.delayed_min_index <- p -let delay_late ctx p f = +let delay_late g p f = let p = Obj.magic p in - let tasks = ctx.g.delayed.(p) in + let tasks = g.delayed.(p) in tasks.tasks <- tasks.tasks @ [f]; - if p < ctx.g.delayed_min_index then - ctx.g.delayed_min_index <- p + if p < g.delayed_min_index then + g.delayed_min_index <- p -let delay_if_mono ctx p t f = match follow t with +let delay_if_mono g p t f = match follow t with | TMono _ -> - delay ctx p f + delay g p f | _ -> f() -let rec flush_pass ctx p where = +let rec flush_pass g p where = let rec loop i = if i > (Obj.magic p) then () else begin - let tasks = ctx.g.delayed.(i) in + let tasks = g.delayed.(i) in match tasks.tasks with | f :: l -> tasks.tasks <- l; f(); - flush_pass ctx p where + flush_pass g p where | [] -> (* Done with this pass (for now), update min index to next one *) let i = i + 1 in - ctx.g.delayed_min_index <- i; + g.delayed_min_index <- i; loop i end in - loop ctx.g.delayed_min_index + loop g.delayed_min_index let make_pass ctx f = f -let enter_field_typing_pass ctx info = - flush_pass ctx PConnectField info +let enter_field_typing_pass g info = + flush_pass g PConnectField info let make_lazy ?(force=true) ctx t_proc f where = let r = ref (lazy_available t_dynamic) in diff --git a/src/typing/finalization.ml b/src/typing/finalization.ml index 61953a43f75..67189a59a15 100644 --- a/src/typing/finalization.ml +++ b/src/typing/finalization.ml @@ -79,7 +79,7 @@ let get_main ctx types = Some main let finalize ctx = - flush_pass ctx PFinal ("final",[]); + flush_pass ctx.g PFinal ("final",[]); match ctx.com.callbacks#get_after_typing with | [] -> () @@ -91,7 +91,7 @@ let finalize ctx = () | new_types -> List.iter (fun f -> f new_types) fl; - flush_pass ctx PFinal ("final",[]); + flush_pass ctx.g PFinal ("final",[]); loop all_types in loop [] diff --git a/src/typing/functionArguments.ml b/src/typing/functionArguments.ml index f7251a69ca3..b1f8566194a 100644 --- a/src/typing/functionArguments.ml +++ b/src/typing/functionArguments.ml @@ -99,7 +99,7 @@ object(self) v.v_meta <- (Meta.This,[],null_pos) :: v.v_meta; loop ((v,None) :: acc) false syntax typed | ((_,pn),opt,m,_,_) :: syntax,(name,eo,t) :: typed -> - delay ctx PTypeField (fun() -> self#check_rest (typed = []) eo opt t pn); + delay ctx.g PTypeField (fun() -> self#check_rest (typed = []) eo opt t pn); if not is_extern then check_local_variable_name ctx name TVOArgument pn; let eo = type_function_arg_value ctx t eo do_display in let v = make_local name (VUser TVOArgument) t m pn in @@ -121,7 +121,7 @@ object(self) | syntax,(name,_,t) :: typed when is_abstract_this -> loop false syntax typed | ((_,pn),opt,m,_,_) :: syntax,(name,eo,t) :: typed -> - delay ctx PTypeField (fun() -> self#check_rest (typed = []) eo opt t pn); + delay ctx.g PTypeField (fun() -> self#check_rest (typed = []) eo opt t pn); ignore(type_function_arg_value ctx t eo do_display); loop false syntax typed | [],[] -> diff --git a/src/typing/generic.ml b/src/typing/generic.ml index 30e59364c07..4f7800f4a5b 100644 --- a/src/typing/generic.ml +++ b/src/typing/generic.ml @@ -337,7 +337,7 @@ let build_generic_class ctx c p tl = | None -> (* There can be cases like #11152 where cf_expr isn't ready yet. It should be safe to delay this to the end of the PTypeField pass. *) - delay_late ctx PTypeField (fun () -> match cf_old.cf_expr with + delay_late ctx.g PTypeField (fun () -> match cf_old.cf_expr with | Some e -> update_expr e | None -> @@ -355,7 +355,7 @@ let build_generic_class ctx c p tl = t in let t = spawn_monomorph ctx.e p in - let r = make_lazy ctx t (fun r -> + let r = make_lazy ctx.g t (fun r -> let t0 = f() in unify_raise t0 t p; link_dynamic t0 t; diff --git a/src/typing/instanceBuilder.ml b/src/typing/instanceBuilder.ml index 5d86ee883b9..8d0eeee7d3f 100644 --- a/src/typing/instanceBuilder.ml +++ b/src/typing/instanceBuilder.ml @@ -74,7 +74,7 @@ let get_build_info ctx mtype p = if ctx.pass > PBuildClass then ignore(c.cl_build()); let build f s tl = let t = spawn_monomorph ctx.e p in - let r = make_lazy ctx t (fun r -> + let r = make_lazy ctx.g t (fun r -> let tf = f tl in unify_raise tf t p; link_dynamic t tf; diff --git a/src/typing/macroContext.ml b/src/typing/macroContext.ml index 76ce2f96e70..9845a863661 100644 --- a/src/typing/macroContext.ml +++ b/src/typing/macroContext.ml @@ -88,7 +88,7 @@ let typing_timer ctx need_type f = ctx.com.error_ext <- (fun err -> raise_error { err with err_from_macro = true }); let ctx = if need_type && ctx.pass < PTypeField then begin - enter_field_typing_pass ctx ("typing_timer",[] (* TODO: ? *)); + enter_field_typing_pass ctx.g ("typing_timer",[] (* TODO: ? *)); TyperManager.clone_for_expr ctx end else ctx @@ -600,7 +600,7 @@ let make_macro_api ctx mctx p = List.iter (fun path -> ImportHandling.init_using ctx path null_pos ) usings; - flush_pass ctx PConnectField ("with_imports",[] (* TODO: ? *)); + flush_pass ctx.g PConnectField ("with_imports",[] (* TODO: ? *)); f() in let restore () = diff --git a/src/typing/strictMeta.ml b/src/typing/strictMeta.ml index 4acc0cf44f3..be91dba715b 100644 --- a/src/typing/strictMeta.ml +++ b/src/typing/strictMeta.ml @@ -172,7 +172,7 @@ let get_strict_meta ctx meta params pos = raise Exit in let t = Typeload.load_complex_type ctx false (ctype,pos) in - flush_pass ctx PBuildClass "get_strict_meta"; + flush_pass ctx.g PBuildClass "get_strict_meta"; let texpr = type_expr ctx changed_expr NoValue in let with_type_expr = (ECheckType( (EConst (Ident "null"), pos), (ctype,null_pos) ), pos) in let extra = handle_fields ctx fields_to_check with_type_expr in diff --git a/src/typing/typeload.ml b/src/typing/typeload.ml index bfba81c88ac..fc8201b5648 100644 --- a/src/typing/typeload.ml +++ b/src/typing/typeload.ml @@ -390,7 +390,7 @@ let rec load_params ctx info params p = let t = apply_params info.build_params params t in maybe_build_instance ctx t ParamNormal p; in - delay ctx PCheckConstraint (fun () -> + delay ctx.g PCheckConstraint (fun () -> DynArray.iter (fun (t,c,p) -> check_param_constraints ctx t map c p ) checks @@ -471,7 +471,7 @@ and load_complex_type' ctx allow_display (t,p) = ) tl in let tr = Monomorph.create() in let t = TMono tr in - let r = make_lazy ctx t (fun r -> + let r = make_lazy ctx.g t (fun r -> let ta = make_extension_type ctx tl in Monomorph.bind tr ta; ta @@ -512,7 +512,7 @@ and load_complex_type' ctx allow_display (t,p) = ) tl in let tr = Monomorph.create() in let t = TMono tr in - let r = make_lazy ctx t (fun r -> + let r = make_lazy ctx.g t (fun r -> Monomorph.bind tr (match il with | [i] -> mk_extension i @@ -616,7 +616,7 @@ and load_complex_type' ctx allow_display (t,p) = | None -> () | Some cf -> - delay ctx PBuildClass (fun () -> DisplayEmitter.display_field ctx (AnonymousStructure a) CFSMember cf cf.cf_name_pos); + delay ctx.g PBuildClass (fun () -> DisplayEmitter.display_field ctx (AnonymousStructure a) CFSMember cf cf.cf_name_pos); end; TAnon a | CTFunction (args,r) -> @@ -635,7 +635,7 @@ and load_complex_type ctx allow_display (t,pn) = load_complex_type' ctx allow_display (t,pn) with Error ({ err_message = Module_not_found(([],name)) } as err) -> if Diagnostics.error_in_diagnostics_run ctx.com err.err_pos then begin - delay ctx PForce (fun () -> DisplayToplevel.handle_unresolved_identifier ctx name err.err_pos true); + delay ctx.g PForce (fun () -> DisplayToplevel.handle_unresolved_identifier ctx name err.err_pos true); t_dynamic end else if ignore_error ctx.com && not (DisplayPosition.display_position#enclosed_in pn) then t_dynamic @@ -745,7 +745,7 @@ and type_type_params ctx host path p tpl = | None -> () | Some ct -> - let r = make_lazy ctx ttp.ttp_type (fun r -> + let r = make_lazy ctx.g ttp.ttp_type (fun r -> let t = load_complex_type ctx true ct in begin match host with | TPHType -> @@ -785,7 +785,7 @@ and type_type_params ctx host path p tpl = List.iter loop constr; constr ) in - delay ctx PConnectField (fun () -> ignore (Lazy.force constraints)); + delay ctx.g PConnectField (fun () -> ignore (Lazy.force constraints)); ttp.ttp_constraints <- Some constraints; ) param_pairs; params @@ -819,7 +819,7 @@ let load_core_class ctx c = | _ -> c.cl_path in let t = load_type_def' ctx2 (fst c.cl_module.m_path) (snd c.cl_module.m_path) (snd tpath) null_pos in - flush_pass ctx2 PFinal ("core_final",(fst c.cl_path @ [snd c.cl_path])); + flush_pass ctx2.g PFinal ("core_final",(fst c.cl_path @ [snd c.cl_path])); match t with | TClassDecl ccore | TAbstractDecl {a_impl = Some ccore} -> ccore diff --git a/src/typing/typeloadCheck.ml b/src/typing/typeloadCheck.ml index 6532c9e99f3..5369903fb96 100644 --- a/src/typing/typeloadCheck.ml +++ b/src/typing/typeloadCheck.ml @@ -47,7 +47,7 @@ let is_generic_parameter ctx c = with Not_found -> false -let valid_redefinition ctx map1 map2 f1 t1 f2 t2 = (* child, parent *) +let valid_redefinition map1 map2 f1 t1 f2 t2 = (* child, parent *) let valid t1 t2 = Type.unify t1 t2; if is_null t1 <> is_null t2 || ((follow t1) == t_dynamic && (follow t2) != t_dynamic) then raise (Unify_error [Cannot_unify (t1,t2)]); @@ -186,7 +186,7 @@ let check_override_field ctx p rctx = display_error ctx.com ("Field " ^ i ^ " has different property access than in superclass") p); if (has_class_field_flag rctx.cf_old CfFinal) then display_error ctx.com ("Cannot override final method " ^ i) p; try - valid_redefinition ctx rctx.map rctx.map rctx.cf_new rctx.cf_new.cf_type rctx.cf_old rctx.t_old; + valid_redefinition rctx.map rctx.map rctx.cf_new rctx.cf_new.cf_type rctx.cf_old rctx.t_old; with Unify_error l -> (* TODO construct error with sub *) @@ -332,7 +332,7 @@ let check_global_metadata ctx meta f_add mpath tpath so = let add = ((field_mode && to_fields) || (not field_mode && to_types)) && (match_path recursive sl1 sl2) in if add then f_add m ) ctx.com.global_metadata; - if ctx.m.is_display_file then delay ctx PCheckConstraint (fun () -> DisplayEmitter.check_display_metadata ctx meta) + if ctx.m.is_display_file then delay ctx.g PCheckConstraint (fun () -> DisplayEmitter.check_display_metadata ctx meta) module Inheritance = struct let is_basic_class_path path = match path with @@ -351,9 +351,9 @@ module Inheritance = struct end | t -> raise_typing_error (Printf.sprintf "Should extend by using a class, found %s" (s_type_kind t)) p - let rec check_interface ctx missing c intf params = + let rec check_interface com g missing c intf params = List.iter (fun (i2,p2) -> - check_interface ctx missing c i2 (List.map (apply_params intf.cl_params params) p2) + check_interface com g missing c i2 (List.map (apply_params intf.cl_params params) p2) ) intf.cl_implements; let p = c.cl_name_pos in let check_field f = @@ -363,7 +363,7 @@ module Inheritance = struct let cf = {f with cf_overloads = []; cf_type = apply_params intf.cl_params params f.cf_type} in begin try let cf' = PMap.find cf.cf_name c.cl_fields in - ctx.com.overload_cache#remove (c.cl_path,f.cf_name); + com.overload_cache#remove (c.cl_path,f.cf_name); cf'.cf_overloads <- cf :: cf'.cf_overloads with Not_found -> TClass.add_field c cf @@ -378,13 +378,13 @@ module Inheritance = struct let map2, t2, f2 = class_field_no_interf c f.cf_name in let t2, f2 = if f2.cf_overloads <> [] || has_class_field_flag f2 CfOverload then - let overloads = get_overloads ctx.com c f.cf_name in + let overloads = get_overloads com c f.cf_name in is_overload := true; List.find (fun (t1,f1) -> Overloads.same_overload_args t t1 f f1) overloads else t2, f2 in - delay ctx PForce (fun () -> + delay g PForce (fun () -> ignore(follow f2.cf_type); (* force evaluation *) let p = f2.cf_name_pos in let mkind = function @@ -393,19 +393,19 @@ module Inheritance = struct | MethMacro -> 2 in if (has_class_field_flag f CfPublic) && not (has_class_field_flag f2 CfPublic) && not (Meta.has Meta.CompilerGenerated f.cf_meta) then - display_error ctx.com ("Field " ^ f.cf_name ^ " should be public as requested by " ^ s_type_path intf.cl_path) p + display_error com ("Field " ^ f.cf_name ^ " should be public as requested by " ^ s_type_path intf.cl_path) p else if not (unify_kind ~strict:false f2.cf_kind f.cf_kind) || not (match f.cf_kind, f2.cf_kind with Var _ , Var _ -> true | Method m1, Method m2 -> mkind m1 = mkind m2 | _ -> false) then - display_error ctx.com ("Field " ^ f.cf_name ^ " has different property access than in " ^ s_type_path intf.cl_path ^ " (" ^ s_kind f2.cf_kind ^ " should be " ^ s_kind f.cf_kind ^ ")") p + display_error com ("Field " ^ f.cf_name ^ " has different property access than in " ^ s_type_path intf.cl_path ^ " (" ^ s_kind f2.cf_kind ^ " should be " ^ s_kind f.cf_kind ^ ")") p else try let map1 = TClass.get_map_function intf params in - valid_redefinition ctx map1 map2 f2 t2 f (apply_params intf.cl_params params f.cf_type) + valid_redefinition map1 map2 f2 t2 f (apply_params intf.cl_params params f.cf_type) with Unify_error l -> if not (Meta.has Meta.CsNative c.cl_meta && (has_class_flag c CExtern)) then begin (* TODO construct error with sub *) - display_error ctx.com ("Field " ^ f.cf_name ^ " has different type than in " ^ s_type_path intf.cl_path) p; - display_error ~depth:1 ctx.com (compl_msg "Interface field is defined here") f.cf_pos; - display_error ~depth:1 ctx.com (compl_msg (error_msg (Unify l))) p; + display_error com ("Field " ^ f.cf_name ^ " has different type than in " ^ s_type_path intf.cl_path) p; + display_error ~depth:1 com (compl_msg "Interface field is defined here") f.cf_pos; + display_error ~depth:1 com (compl_msg (error_msg (Unify l))) p; end ) with Not_found -> @@ -418,7 +418,7 @@ module Inheritance = struct add_class_field_flag cf CfExtern; add_class_field_flag cf CfOverride; end else if not (has_class_flag c CInterface) then begin - if Diagnostics.error_in_diagnostics_run ctx.com c.cl_pos then + if Diagnostics.error_in_diagnostics_run com c.cl_pos then DynArray.add missing (f,t) else begin let msg = if !is_overload then @@ -428,7 +428,7 @@ module Inheritance = struct else ("Field " ^ f.cf_name ^ " needed by " ^ s_type_path intf.cl_path ^ " is missing") in - display_error ctx.com msg p + display_error com msg p end end in @@ -445,7 +445,7 @@ module Inheritance = struct | _ -> List.iter (fun (intf,params) -> let missing = DynArray.create () in - check_interface ctx missing c intf params; + check_interface ctx.com ctx.g missing c intf params; if DynArray.length missing > 0 then begin let l = DynArray.to_list missing in let diag = { @@ -544,7 +544,7 @@ module Inheritance = struct we do want to check them at SOME point. So we use this pending list which was maybe designed for this purpose. However, we STILL have to delay the check because at the time pending is handled, the class is not built yet. See issue #10847. *) - pending := (fun () -> delay ctx PConnectField check_interfaces_or_delay) :: !pending + pending := (fun () -> delay ctx.g PConnectField check_interfaces_or_delay) :: !pending | _ when ctx.com.display.dms_full_typing -> check_interfaces ctx c | _ -> @@ -557,7 +557,7 @@ module Inheritance = struct if not (has_class_flag csup CInterface) then raise_typing_error (Printf.sprintf "Cannot extend by using a class (%s extends %s)" (s_type_path c.cl_path) (s_type_path csup.cl_path)) p; c.cl_implements <- (csup,params) :: c.cl_implements; if not !has_interf then begin - if not is_lib then delay ctx PConnectField check_interfaces_or_delay; + if not is_lib then delay ctx.g PConnectField check_interfaces_or_delay; has_interf := true; end end else begin @@ -579,7 +579,7 @@ module Inheritance = struct if not (has_class_flag intf CInterface) then raise_typing_error "You can only implement an interface" p; c.cl_implements <- (intf, params) :: c.cl_implements; if not !has_interf && not is_lib && not (Meta.has (Meta.Custom "$do_not_check_interf") c.cl_meta) then begin - delay ctx PConnectField check_interfaces_or_delay; + delay ctx.g PConnectField check_interfaces_or_delay; has_interf := true; end; (fun () -> diff --git a/src/typing/typeloadFields.ml b/src/typing/typeloadFields.ml index 8a382466d65..43a05c888ad 100644 --- a/src/typing/typeloadFields.ml +++ b/src/typing/typeloadFields.ml @@ -240,7 +240,7 @@ let ensure_struct_init_constructor ctx c ast_fields p = cf.cf_meta <- [Meta.CompilerGenerated,[],null_pos; Meta.InheritDoc,[],null_pos]; cf.cf_kind <- Method MethNormal; c.cl_constructor <- Some cf; - delay ctx PTypeField (fun() -> InheritDoc.build_class_field_doc ctx (Some c) cf) + delay ctx.g PTypeField (fun() -> InheritDoc.build_class_field_doc ctx (Some c) cf) let transform_abstract_field com this_t a_t a f = let stat = List.mem_assoc AStatic f.cff_access in @@ -485,7 +485,7 @@ let build_module_def ctx mt meta fvars fbuild = | _ -> t_infos mt in (* Delay for #10107, but use delay_late to make sure base classes run before their children do. *) - delay_late ctx PConnectField (fun () -> + delay_late ctx.g PConnectField (fun () -> ti.mt_using <- (filter_classes types) @ ti.mt_using ) with Exit -> @@ -509,7 +509,7 @@ let build_module_def ctx mt meta fvars fbuild = let inherit_using (c,_) = ti.mt_using <- ti.mt_using @ (t_infos (TClassDecl c)).mt_using in - delay_late ctx PConnectField (fun () -> + delay_late ctx.g PConnectField (fun () -> Option.may inherit_using csup; List.iter inherit_using interfaces; ); @@ -743,7 +743,7 @@ module TypeBinding = struct in let force_macro display = (* force macro system loading of this class in order to get completion *) - delay ctx PTypeField (fun() -> + delay ctx.g PTypeField (fun() -> try ignore(ctx.g.do_macro ctx MDisplay c.cl_path cf.cf_name [] p) with @@ -828,10 +828,10 @@ module TypeBinding = struct mk_cast e cf.cf_type e.epos end in - let r = make_lazy ~force:false ctx t (fun r -> + let r = make_lazy ~force:false ctx.g t (fun r -> (* type constant init fields (issue #1956) *) if not ctx.g.return_partial_type || (match fst e with EConst _ -> true | _ -> false) then begin - enter_field_typing_pass ctx ("bind_var_expression",fst ctx.c.curclass.cl_path @ [snd ctx.c.curclass.cl_path;ctx.f.curfield.cf_name]); + enter_field_typing_pass ctx.g ("bind_var_expression",fst ctx.c.curclass.cl_path @ [snd ctx.c.curclass.cl_path;ctx.f.curfield.cf_name]); if (Meta.has (Meta.Custom ":debug.typing") (c.cl_meta @ cf.cf_meta)) then ctx.com.print (Printf.sprintf "Typing field %s.%s\n" (s_type_path c.cl_path) cf.cf_name); let e = type_var_field ctx t e fctx.is_static fctx.is_display_field p in let maybe_run_analyzer e = match e.eexpr with @@ -963,7 +963,7 @@ module TypeBinding = struct if not ctx.g.return_partial_type then bind r; t in - let r = make_lazy ~force:false ctx t maybe_bind "type_fun" in + let r = make_lazy ~force:false ctx.g t maybe_bind "type_fun" in bind_type ctx cctx fctx cf r p end @@ -1027,7 +1027,7 @@ let check_abstract (ctx,cctx,fctx) a c cf fd t ret p = fctx.expr_presence_matters <- true; end in let handle_from () = - let r = make_lazy ctx t (fun r -> + let r = make_lazy ctx.g t (fun r -> (* the return type of a from-function must be the abstract, not the underlying type *) if not fctx.is_macro then (try type_eq EqStrict ret ta with Unify_error l -> raise_typing_error_ext (make_error (Unify l) p)); match t with @@ -1067,7 +1067,7 @@ let check_abstract (ctx,cctx,fctx) a c cf fd t ret p = let is_multitype_cast = Meta.has Meta.MultiType a.a_meta && not fctx.is_abstract_member in if is_multitype_cast && not (Meta.has Meta.MultiType cf.cf_meta) then cf.cf_meta <- (Meta.MultiType,[],null_pos) :: cf.cf_meta; - let r = make_lazy ctx t (fun r -> + let r = make_lazy ctx.g t (fun r -> let args = if is_multitype_cast then begin let ctor = try PMap.find "_new" c.cl_statics @@ -1415,14 +1415,14 @@ let create_method (ctx,cctx,fctx) c f fd p = TypeBinding.bind_method ctx cctx fctx cf t args ret fd.f_expr (match fd.f_expr with Some e -> snd e | None -> f.cff_pos) else begin if fctx.is_display_field then begin - delay ctx PTypeField (fun () -> + delay ctx.g PTypeField (fun () -> (* We never enter type_function so we're missing out on the argument processing there. Let's do it here. *) let ctx = TyperManager.clone_for_expr ctx in ignore(args#for_expr ctx) ); check_field_display ctx fctx c cf; end else - delay ctx PTypeField (fun () -> + delay ctx.g PTypeField (fun () -> let ctx = TyperManager.clone_for_expr ctx in args#verify_extern ctx ); @@ -1482,7 +1482,7 @@ let create_property (ctx,cctx,fctx) c f (get,set,t,eo) p = (* Now that we know there is a field, we have to delay the actual unification even further. The reason is that unification could resolve TLazy, which would then cause field typing before we're done with our PConnectField pass. This could cause interface fields to not be generated in time. *) - delay ctx PForce (fun () -> + delay ctx.g PForce (fun () -> try (match f2.cf_kind with | Method MethMacro -> @@ -1534,7 +1534,7 @@ let create_property (ctx,cctx,fctx) c f (get,set,t,eo) p = with Not_found -> () in - let delay_check = delay ctx PConnectField in + let delay_check = delay ctx.g PConnectField in let get = (match get with | "null",_ -> AccNo | "dynamic",_ -> AccCall @@ -1542,7 +1542,7 @@ let create_property (ctx,cctx,fctx) c f (get,set,t,eo) p = | "default",_ -> AccNormal | "get",pget -> let get = "get_" ^ name in - if fctx.is_display_field && DisplayPosition.display_position#enclosed_in pget then delay ctx PConnectField (fun () -> display_accessor get pget); + if fctx.is_display_field && DisplayPosition.display_position#enclosed_in pget then delay ctx.g PConnectField (fun () -> display_accessor get pget); if not cctx.is_lib then delay_check (fun() -> check_method get t_get true); AccCall | _,pget -> @@ -1561,7 +1561,7 @@ let create_property (ctx,cctx,fctx) c f (get,set,t,eo) p = | "default",_ -> AccNormal | "set",pset -> let set = "set_" ^ name in - if fctx.is_display_field && DisplayPosition.display_position#enclosed_in pset then delay ctx PConnectField (fun () -> display_accessor set pset); + if fctx.is_display_field && DisplayPosition.display_position#enclosed_in pset then delay ctx.g PConnectField (fun () -> display_accessor set pset); if not cctx.is_lib then delay_check (fun() -> check_method set t_set false); AccCall | _,pset -> @@ -1632,7 +1632,7 @@ let init_field (ctx,cctx,fctx) f = in (if (fctx.is_static || fctx.is_macro && ctx.com.is_macro_context) then add_class_field_flag cf CfStatic); if Meta.has Meta.InheritDoc cf.cf_meta then - delay ctx PTypeField (fun() -> InheritDoc.build_class_field_doc ctx (Some c) cf); + delay ctx.g PTypeField (fun() -> InheritDoc.build_class_field_doc ctx (Some c) cf); cf let check_overload ctx f fs is_extern_class = @@ -1685,7 +1685,7 @@ let finalize_class cctx = List.iter (fun (ctx,r) -> (match r with | None -> () - | Some r -> delay ctx PTypeField (fun() -> ignore(lazy_type r))) + | Some r -> delay ctx.g PTypeField (fun() -> ignore(lazy_type r))) ) cctx.delayed_expr let check_functional_interface ctx c = @@ -1717,13 +1717,13 @@ let init_class ctx_c cctx c p herits fields = if cctx.is_class_debug then print_endline ("Created class context: " ^ dump_class_context cctx); let fields = patch_class ctx_c c fields in let fields = build_fields (ctx_c,cctx) c fields in - if cctx.is_core_api && com.display.dms_check_core_api then delay ctx_c PForce (fun() -> init_core_api ctx_c c); + if cctx.is_core_api && com.display.dms_check_core_api then delay ctx_c.g PForce (fun() -> init_core_api ctx_c c); if not cctx.is_lib then begin - delay ctx_c PForce (fun() -> check_overloads ctx_c c); + delay ctx_c.g PForce (fun() -> check_overloads ctx_c c); begin match c.cl_super with | Some(csup,tl) -> if (has_class_flag csup CAbstract) && not (has_class_flag c CAbstract) then - delay ctx_c PForce (fun () -> TypeloadCheck.Inheritance.check_abstract_class ctx_c c csup tl); + delay ctx_c.g PForce (fun () -> TypeloadCheck.Inheritance.check_abstract_class ctx_c c csup tl); | None -> () end @@ -1838,7 +1838,7 @@ let init_class ctx_c cctx c p herits fields = end; c.cl_ordered_statics <- List.rev c.cl_ordered_statics; c.cl_ordered_fields <- List.rev c.cl_ordered_fields; - delay ctx_c PConnectField (fun () -> match follow c.cl_type with + delay ctx_c.g PConnectField (fun () -> match follow c.cl_type with | TAnon an -> an.a_fields <- c.cl_statics | _ -> diff --git a/src/typing/typeloadFunction.ml b/src/typing/typeloadFunction.ml index 9e8b073b3c6..14aca0ba064 100644 --- a/src/typing/typeloadFunction.ml +++ b/src/typing/typeloadFunction.ml @@ -42,7 +42,7 @@ let type_function ctx (args : function_arguments) ret fmode e do_display p = ctx.e.ret <- ret; ctx.e.opened <- []; ctx.e.monomorphs.perfunction <- []; - enter_field_typing_pass ctx ("type_function",fst ctx.c.curclass.cl_path @ [snd ctx.c.curclass.cl_path;ctx.f.curfield.cf_name]); + enter_field_typing_pass ctx.g ("type_function",fst ctx.c.curclass.cl_path @ [snd ctx.c.curclass.cl_path;ctx.f.curfield.cf_name]); args#bring_into_context ctx; let e = match e with | None -> @@ -113,7 +113,7 @@ let type_function ctx (args : function_arguments) ret fmode e do_display p = let e = if fmode <> FunConstructor then e else begin - delay ctx PForce (fun () -> TypeloadCheck.check_final_vars ctx e); + delay ctx.g PForce (fun () -> TypeloadCheck.check_final_vars ctx e); match has_super_constr() with | Some (was_forced,t_super) -> (try @@ -177,7 +177,7 @@ let add_constructor ctx_c c force_constructor p = cf.cf_params <- cfsup.cf_params; cf.cf_meta <- List.filter (fun (m,_,_) -> m = Meta.CompilerGenerated) cfsup.cf_meta; let t = spawn_monomorph ctx_c.e p in - let r = make_lazy ctx_c t (fun r -> + let r = make_lazy ctx_c.g t (fun r -> let ctx = TyperManager.clone_for_field ctx_c cf cf.cf_params in ignore (follow cfsup.cf_type); (* make sure it's typed *) List.iter (fun cf -> ignore (follow cf.cf_type)) cf.cf_overloads; diff --git a/src/typing/typeloadModule.ml b/src/typing/typeloadModule.ml index 1966c5eb1d5..960d1540ee2 100644 --- a/src/typing/typeloadModule.ml +++ b/src/typing/typeloadModule.ml @@ -152,7 +152,7 @@ module ModuleLevel = struct t_meta = d.d_meta; } in (* failsafe in case the typedef is not initialized (see #3933) *) - delay ctx_m PBuildModule (fun () -> + delay ctx_m.g PBuildModule (fun () -> match t.t_type with | TMono r -> (match r.tm_type with None -> Monomorph.bind r com.basic.tvoid | _ -> ()) | _ -> () @@ -408,7 +408,7 @@ module TypeLevel = struct with TypeloadCheck.Build_canceled state -> c.cl_build <- make_pass ctx_c build; let rebuild() = - delay_late ctx_c PBuildClass (fun() -> ignore(c.cl_build())); + delay_late ctx_c.g PBuildClass (fun() -> ignore(c.cl_build())); in (match state with | Built -> die "" __LOC__ @@ -427,11 +427,11 @@ module TypeLevel = struct build() in c.cl_build <- make_pass ctx_m build; - delay ctx_m PBuildClass (fun() -> ignore(c.cl_build())); + delay ctx_m.g PBuildClass (fun() -> ignore(c.cl_build())); if Meta.has Meta.InheritDoc c.cl_meta then - delay ctx_m PConnectField (fun() -> InheritDoc.build_class_doc ctx_m c); + delay ctx_m.g PConnectField (fun() -> InheritDoc.build_class_doc ctx_m c); if (ctx_m.com.platform = Java || ctx_m.com.platform = Cs) && not (has_class_flag c CExtern) then - delay ctx_m PTypeField (fun () -> + delay ctx_m.g PTypeField (fun () -> let metas = StrictMeta.check_strict_meta ctx_m c.cl_meta in if metas <> [] then c.cl_meta <- metas @ c.cl_meta; let rec run_field cf = @@ -507,16 +507,16 @@ module TypeLevel = struct incr index; names := (fst c.ec_name) :: !names; if Meta.has Meta.InheritDoc f.ef_meta then - delay ctx_en PConnectField (fun() -> InheritDoc.build_enum_field_doc ctx_en f); + delay ctx_en.g PConnectField (fun() -> InheritDoc.build_enum_field_doc ctx_en f); ) (!constructs); e.e_names <- List.rev !names; e.e_extern <- e.e_extern; unify ctx_en (TType(enum_module_type e,[])) e.e_type p; if !is_flat then e.e_meta <- (Meta.FlatEnum,[],null_pos) :: e.e_meta; if Meta.has Meta.InheritDoc e.e_meta then - delay ctx_en PConnectField (fun() -> InheritDoc.build_enum_doc ctx_en e); + delay ctx_en.g PConnectField (fun() -> InheritDoc.build_enum_doc ctx_en e); if (ctx_en.com.platform = Java || ctx_en.com.platform = Cs) && not e.e_extern then - delay ctx_en PTypeField (fun () -> + delay ctx_en.g PTypeField (fun () -> let metas = StrictMeta.check_strict_meta ctx_en e.e_meta in e.e_meta <- metas @ e.e_meta; PMap.iter (fun _ ef -> @@ -556,7 +556,7 @@ module TypeLevel = struct | _ -> () in - let r = make_lazy ctx_td tt (fun r -> + let r = make_lazy ctx_td.g tt (fun r -> check_rec tt; tt ) "typedef_rec_check" in @@ -571,7 +571,7 @@ module TypeLevel = struct | _ -> die "" __LOC__); TypeloadFields.build_module_def ctx_td (TTypeDecl t) t.t_meta (fun _ -> []) (fun _ -> ()); if ctx_td.com.platform = Cs && t.t_meta <> [] then - delay ctx_td PTypeField (fun () -> + delay ctx_td.g PTypeField (fun () -> let metas = StrictMeta.check_strict_meta ctx_td t.t_meta in if metas <> [] then t.t_meta <- metas @ t.t_meta; ) @@ -587,7 +587,7 @@ module TypeLevel = struct let t = load_complex_type ctx_a true t in let t = if not (Meta.has Meta.CoreType a.a_meta) then begin if !is_type then begin - let r = make_lazy ctx_a t (fun r -> + let r = make_lazy ctx_a.g t (fun r -> (try (if from then Type.unify t a.a_this else Type.unify a.a_this t) with Unify_error _ -> raise_typing_error "You can only declare from/to with compatible types" pos); t ) "constraint" in @@ -608,7 +608,7 @@ module TypeLevel = struct if a.a_impl = None then raise_typing_error "Abstracts with underlying type must have an implementation" a.a_pos; if Meta.has Meta.CoreType a.a_meta then raise_typing_error "@:coreType abstracts cannot have an underlying type" p; let at = load_complex_type ctx_a true t in - delay ctx_a PForce (fun () -> + delay ctx_a.g PForce (fun () -> let rec loop stack t = match follow t with | TAbstract(a,_) when not (Meta.has Meta.CoreType a.a_meta) -> @@ -635,7 +635,7 @@ module TypeLevel = struct raise_typing_error "Abstract is missing underlying type declaration" a.a_pos end; if Meta.has Meta.InheritDoc a.a_meta then - delay ctx_a PConnectField (fun() -> InheritDoc.build_abstract_doc ctx_a a) + delay ctx_a.g PConnectField (fun() -> InheritDoc.build_abstract_doc ctx_a a) (* In this pass, we can access load and access other modules types, but we cannot follow them or access their structure @@ -716,7 +716,7 @@ let type_types_into_module com g m tdecls p = (* setup module types *) List.iter (TypeLevel.init_module_type ctx_m) tdecls; (* Make sure that we actually init the context at some point (issue #9012) *) - delay ctx_m PConnectField (fun () -> ctx_m.m.import_resolution#resolve_lazies); + delay ctx_m.g PConnectField (fun () -> ctx_m.m.import_resolution#resolve_lazies); ctx_m (* @@ -770,7 +770,7 @@ class hxb_reader_api_typeload | Var _ -> true | Method _ -> - delay ctx PTypeField (fun () -> ignore(follow cf.cf_type)); + delay ctx.g PTypeField (fun () -> ignore(follow cf.cf_type)); false end @@ -781,7 +781,7 @@ let rec load_hxb_module ctx path p = let reader = new HxbReader.hxb_reader path ctx.com.hxb_reader_stats in let read = reader#read api bytes in let m = read EOT in - delay ctx PConnectField (fun () -> + delay ctx.g PConnectField (fun () -> ignore(read EOM); ); m @@ -847,7 +847,7 @@ and load_module' ctx m p = let load_module ctx m p = let m2 = load_module' ctx m p in add_dependency ~skip_postprocess:true ctx.m.curmod m2; - if ctx.pass = PTypeField then flush_pass ctx PConnectField ("load_module",fst m @ [snd m]); + if ctx.pass = PTypeField then flush_pass ctx.g PConnectField ("load_module",fst m @ [snd m]); m2 (* let load_module ctx m p = diff --git a/src/typing/typer.ml b/src/typing/typer.ml index 4299d9d1780..1ad869b5b5f 100644 --- a/src/typing/typer.ml +++ b/src/typing/typer.ml @@ -737,7 +737,7 @@ and type_vars ctx vl p = add_local ctx VGenerated n t_dynamic pv, None (* TODO: What to do with this... *) ) vl in List.iter (fun (v,_) -> - delay_if_mono ctx PTypeField v.v_type (fun() -> + delay_if_mono ctx.g PTypeField v.v_type (fun() -> if ExtType.is_void (follow v.v_type) then raise_typing_error "Variables of type Void are not allowed" v.v_pos ) From 8022d4eb2dd65d352a0d0adbdfedcc869e55d893 Mon Sep 17 00:00:00 2001 From: Simon Krajewski Date: Fri, 2 Feb 2024 22:31:28 +0100 Subject: [PATCH 09/16] lose server dependency on typer --- src/compiler/server.ml | 80 +++++++++++++---------------- src/context/display/displayTexpr.ml | 2 +- src/context/typecore.ml | 25 --------- src/typing/macroContext.ml | 2 +- src/typing/typeloadCacheHook.ml | 31 +++++++++++ src/typing/typeloadModule.ml | 6 +-- src/typing/typeloadParse.ml | 8 +-- 7 files changed, 74 insertions(+), 80 deletions(-) create mode 100644 src/typing/typeloadCacheHook.ml diff --git a/src/compiler/server.ml b/src/compiler/server.ml index e664d8691a7..62629092446 100644 --- a/src/compiler/server.ml +++ b/src/compiler/server.ml @@ -3,13 +3,13 @@ open Common open CompilationCache open Timer open Type -open Typecore open DisplayProcessingGlobals open Ipaddr open Json open CompilationContext open MessageReporting open HxbData +open TypeloadCacheHook exception Dirty of module_skip_reason exception ServerError of string @@ -162,10 +162,9 @@ let stat dir = (Unix.stat (Path.remove_trailing_slash dir)).Unix.st_mtime (* Gets a list of changed directories for the current compilation. *) -let get_changed_directories sctx (ctx : Typecore.typer) = +let get_changed_directories sctx com = let t = Timer.timer ["server";"module cache";"changed dirs"] in let cs = sctx.cs in - let com = ctx.Typecore.com in let sign = Define.get_signature com.defines in let dirs = try (* First, check if we already have determined changed directories for current compilation. *) @@ -229,16 +228,15 @@ let get_changed_directories sctx (ctx : Typecore.typer) = (* Checks if module [m] can be reused from the cache and returns None in that case. Otherwise, returns [Some m'] where [m'] is the module responsible for [m] not being reusable. *) -let check_module sctx ctx m_path m_extra p = - let com = ctx.Typecore.com in +let check_module sctx com m_path m_extra p = let cc = CommonCache.get_cache com in let content_changed m_path file = - let fkey = ctx.com.file_keys#get file in + let fkey = com.file_keys#get file in try let cfile = cc#find_file fkey in (* We must use the module path here because the file path is absolute and would cause positions in the parsed declarations to differ. *) - let new_data = TypeloadParse.parse_module ctx m_path p in + let new_data = TypeloadParse.parse_module com m_path p in cfile.c_decls <> snd new_data with Not_found -> true @@ -259,7 +257,7 @@ let check_module sctx ctx m_path m_extra p = let unknown_state_modules = ref [] in let rec check m_path m_extra = let check_module_path () = - let directories = get_changed_directories sctx ctx in + let directories = get_changed_directories sctx com in match m_extra.m_kind with | MFake | MImport -> () (* don't get classpath *) | MExtern -> @@ -285,18 +283,12 @@ let check_module sctx ctx m_path m_extra p = | MMacro when com.is_macro_context -> check_module_shadowing directories m_path m_extra | MMacro -> - (* - Creating another context while the previous one is incomplete means we have an infinite loop in the compiler. - Most likely because of circular dependencies in base modules (e.g. `StdTypes` or `String`) - Prevents spending another 5 hours for debugging. - @see https://github.com/HaxeFoundation/haxe/issues/8174 - *) - if not ctx.g.complete && ctx.com.is_macro_context then - raise (ServerError ("Infinite loop in Haxe server detected. " - ^ "Probably caused by shadowing a module of the standard library. " - ^ "Make sure shadowed module does not pull macro context.")); - let mctx = MacroContext.get_macro_context ctx in - check_module_shadowing (get_changed_directories sctx mctx) m_path m_extra + begin match com.get_macros() with + | None -> + () + | Some mcom -> + check_module_shadowing (get_changed_directories sctx mcom) m_path m_extra + end in let has_policy policy = List.mem policy m_extra.m_check_policy || match policy with | NoCheckShadowing | NoCheckFileTimeModification when !ServerConfig.do_not_check_modules && !Parser.display_mode <> DMNone -> true @@ -309,7 +301,7 @@ let check_module sctx ctx m_path m_extra p = ServerMessage.unchanged_content com "" file; end else begin ServerMessage.not_cached com "" m_path; - if m_extra.m_kind = MFake then Hashtbl.remove Typecore.fake_modules (Path.UniqueKey.lazy_key m_extra.m_file); + if m_extra.m_kind = MFake then Hashtbl.remove fake_modules (Path.UniqueKey.lazy_key m_extra.m_file); raise (Dirty (FileChanged file)) end end @@ -395,7 +387,7 @@ let check_module sctx ctx m_path m_extra p = state class hxb_reader_api_server - (ctx : Typecore.typer) + (com : Common.context) (cc : context_cache) = object(self) @@ -410,7 +402,7 @@ class hxb_reader_api_server } method add_module (m : module_def) = - ctx.com.module_lut#add m.m_path m + com.module_lut#add m.m_path m method resolve_type (pack : string list) (mname : string) (tname : string) = let path = (pack,mname) in @@ -422,7 +414,7 @@ class hxb_reader_api_server | GoodModule m -> m | BinaryModule mc -> - let reader = new HxbReader.hxb_reader path ctx.com.hxb_reader_stats in + let reader = new HxbReader.hxb_reader path com.hxb_reader_stats in let f_next chunks until = let t_hxb = Timer.timer ["server";"module cache";"hxb read"] in let r = reader#read_chunks_until (self :> HxbReaderApi.hxb_reader_api) chunks until in @@ -434,7 +426,7 @@ class hxb_reader_api_server (* We try to avoid reading expressions as much as possible, so we only do this for our current display file if we're in display mode. *) let is_display_file = DisplayPosition.display_position#is_in_file (Path.UniqueKey.lazy_key m.m_extra.m_file) in - if is_display_file || ctx.com.display.dms_full_typing then ignore(f_next chunks EOM); + if is_display_file || com.display.dms_full_typing then ignore(f_next chunks EOM); m | BadModule reason -> die (Printf.sprintf "Unexpected BadModule %s" (s_type_path path)) __LOC__ @@ -443,7 +435,7 @@ class hxb_reader_api_server method find_module (m_path : path) = try - GoodModule (ctx.com.module_lut#find m_path) + GoodModule (com.module_lut#find m_path) with Not_found -> try let mc = cc#get_hxb_module m_path in begin match mc.mc_extra.m_cache_state with @@ -454,13 +446,13 @@ class hxb_reader_api_server NoModule method basic_types = - ctx.com.basic + com.basic method get_var_id (i : int) = i method read_expression_eagerly (cf : tclass_field) = - ctx.com.display.dms_full_typing + com.display.dms_full_typing end let handle_cache_bound_objects com cbol = @@ -475,12 +467,11 @@ let handle_cache_bound_objects com cbol = (* Adds module [m] and all its dependencies (recursively) from the cache to the current compilation context. *) -let rec add_modules sctx ctx (m : module_def) (from_binary : bool) (p : pos) = - let com = ctx.Typecore.com in +let rec add_modules sctx com (m : module_def) (from_binary : bool) (p : pos) = let own_sign = CommonCache.get_cache_sign com in let rec add_modules tabs m0 m = - if m.m_extra.m_added < ctx.com.compilation_step then begin - m.m_extra.m_added <- ctx.com.compilation_step; + if m.m_extra.m_added < com.compilation_step then begin + m.m_extra.m_added <- com.compilation_step; (match m0.m_extra.m_kind, m.m_extra.m_kind with | MCode, MMacro | MMacro, MCode -> (* this was just a dependency to check : do not add to the context *) @@ -501,7 +492,7 @@ let rec add_modules sctx ctx (m : module_def) (from_binary : bool) (p : pos) = let m2 = try com.module_lut#find mpath with Not_found -> - match type_module sctx ctx mpath p with + match type_module sctx com mpath p with | GoodModule m -> m | BinaryModule mc -> @@ -521,9 +512,8 @@ let rec add_modules sctx ctx (m : module_def) (from_binary : bool) (p : pos) = (* Looks up the module referred to by [mpath] in the cache. If it exists, a check is made to determine if it's still valid. If this function returns None, the module is re-typed. *) -and type_module sctx (ctx:Typecore.typer) mpath p = +and type_module sctx com mpath p = let t = Timer.timer ["server";"module cache"] in - let com = ctx.Typecore.com in let cc = CommonCache.get_cache com in let skip m_path reason = ServerMessage.skipping_dep com "" (m_path,(Printer.s_module_skip_reason reason)); @@ -531,17 +521,17 @@ and type_module sctx (ctx:Typecore.typer) mpath p = in let add_modules from_binary m = let tadd = Timer.timer ["server";"module cache";"add modules"] in - add_modules sctx ctx m from_binary p; + add_modules sctx com m from_binary p; tadd(); GoodModule m in - let check_module sctx ctx m_path m_extra p = + let check_module sctx m_path m_extra p = let tcheck = Timer.timer ["server";"module cache";"check"] in - let r = check_module sctx ctx mpath m_extra p in + let r = check_module sctx com mpath m_extra p in tcheck(); r in - let find_module_in_cache ctx cc m_path p = + let find_module_in_cache cc m_path p = try let m = cc#find_module m_path in begin match m.m_extra.m_cache_state with @@ -558,11 +548,11 @@ and type_module sctx (ctx:Typecore.typer) mpath p = NoModule in (* Should not raise anything! *) - let m = match find_module_in_cache ctx cc mpath p with + let m = match find_module_in_cache cc mpath p with | GoodModule m -> (* "Good" here is an assumption, it only means that the module wasn't explicitly invalidated in the cache. The true cache state will be known after check_module. *) - begin match check_module sctx ctx mpath m.m_extra p with + begin match check_module sctx mpath m.m_extra p with | None -> add_modules false m; | Some reason -> @@ -571,10 +561,10 @@ and type_module sctx (ctx:Typecore.typer) mpath p = | BinaryModule mc -> (* Similarly, we only know that a binary module wasn't explicitly tainted. Decode it only after checking dependencies. This means that the actual decoding never has any reason to fail. *) - begin match check_module sctx ctx mpath mc.mc_extra p with + begin match check_module sctx mpath mc.mc_extra p with | None -> let reader = new HxbReader.hxb_reader mpath com.hxb_reader_stats in - let api = (new hxb_reader_api_server ctx cc :> HxbReaderApi.hxb_reader_api) in + let api = (new hxb_reader_api_server com cc :> HxbReaderApi.hxb_reader_api) in let f_next chunks until = let t_hxb = Timer.timer ["server";"module cache";"hxb read"] in let r = reader#read_chunks_until api chunks until in @@ -585,7 +575,7 @@ and type_module sctx (ctx:Typecore.typer) mpath p = (* We try to avoid reading expressions as much as possible, so we only do this for our current display file if we're in display mode. *) let is_display_file = DisplayPosition.display_position#is_in_file (Path.UniqueKey.lazy_key m.m_extra.m_file) in - if is_display_file || ctx.com.display.dms_full_typing then ignore(f_next chunks EOM); + if is_display_file || com.display.dms_full_typing then ignore(f_next chunks EOM); add_modules true m; | Some reason -> skip mpath reason @@ -759,7 +749,7 @@ let do_connect ip port args = if !has_error then exit 1 let enable_cache_mode sctx = - TypeloadModule.type_module_hook := type_module sctx; + type_module_hook := type_module sctx; ServerCompilationContext.ensure_macro_setup sctx; TypeloadParse.parse_hook := parse_file sctx.cs diff --git a/src/context/display/displayTexpr.ml b/src/context/display/displayTexpr.ml index 928ac013bbf..93d9f2a9f65 100644 --- a/src/context/display/displayTexpr.ml +++ b/src/context/display/displayTexpr.ml @@ -173,7 +173,7 @@ let check_display_file ctx cs = let m = try ctx.com.module_lut#find path with Not_found -> - begin match !TypeloadModule.type_module_hook ctx path null_pos with + begin match !TypeloadCacheHook.type_module_hook ctx.com path null_pos with | NoModule | BadModule _ -> raise Not_found | BinaryModule mc -> let api = (new TypeloadModule.hxb_reader_api_typeload ctx TypeloadModule.load_module' p :> HxbReaderApi.hxb_reader_api) in diff --git a/src/context/typecore.ml b/src/context/typecore.ml index 7f88172d8bc..784717bbc9c 100644 --- a/src/context/typecore.ml +++ b/src/context/typecore.ml @@ -324,13 +324,6 @@ type dot_path_part = { case : dot_path_part_case; pos : pos } - -type find_module_result = - | GoodModule of module_def - | BadModule of module_skip_reason - | BinaryModule of HxbData.module_cache - | NoModule - let make_build_info kind path params extern apply = { build_kind = kind; build_path = path; @@ -582,24 +575,6 @@ let make_lazy ?(force=true) ctx t_proc f where = if force then delay ctx PForce (fun () -> ignore(lazy_type r)); r -let fake_modules = Hashtbl.create 0 -let create_fake_module ctx file = - let key = ctx.com.file_keys#get file in - let file = Path.get_full_path file in - let mdep = (try Hashtbl.find fake_modules key with Not_found -> - let mdep = { - m_id = alloc_mid(); - m_path = (["$DEP"],file); - m_types = []; - m_statics = None; - m_extra = module_extra file (Define.get_signature ctx.com.defines) (file_time file) MFake ctx.com.compilation_step []; - } in - Hashtbl.add fake_modules key mdep; - mdep - ) in - ctx.com.module_lut#add mdep.m_path mdep; - mdep - let is_removable_field com f = not (has_class_field_flag f CfOverride) && ( has_class_field_flag f CfExtern || has_class_field_flag f CfGeneric diff --git a/src/typing/macroContext.ml b/src/typing/macroContext.ml index 9845a863661..6eb4eb50648 100644 --- a/src/typing/macroContext.ml +++ b/src/typing/macroContext.ml @@ -554,7 +554,7 @@ let make_macro_api ctx mctx p = ctx.m.curmod.m_extra.m_deps <- old_deps; m ) in - add_dependency m (create_fake_module ctx file); + add_dependency m (TypeloadCacheHook.create_fake_module ctx.com file); ); MacroApi.current_module = (fun() -> ctx.m.curmod diff --git a/src/typing/typeloadCacheHook.ml b/src/typing/typeloadCacheHook.ml new file mode 100644 index 00000000000..b9be6a15346 --- /dev/null +++ b/src/typing/typeloadCacheHook.ml @@ -0,0 +1,31 @@ +open Globals +open TType +open Common +open TFunctions + +type find_module_result = + | GoodModule of module_def + | BadModule of module_skip_reason + | BinaryModule of HxbData.module_cache + | NoModule + +let type_module_hook : (Common.context -> path -> pos -> find_module_result) ref = ref (fun _ _ _ -> NoModule) + +let fake_modules = Hashtbl.create 0 + +let create_fake_module com file = + let key = com.file_keys#get file in + let file = Path.get_full_path file in + let mdep = (try Hashtbl.find fake_modules key with Not_found -> + let mdep = { + m_id = alloc_mid(); + m_path = (["$DEP"],file); + m_types = []; + m_statics = None; + m_extra = module_extra file (Define.get_signature com.defines) (file_time file) MFake com.compilation_step []; + } in + Hashtbl.add fake_modules key mdep; + mdep + ) in + com.module_lut#add mdep.m_path mdep; + mdep \ No newline at end of file diff --git a/src/typing/typeloadModule.ml b/src/typing/typeloadModule.ml index 960d1540ee2..43092acda96 100644 --- a/src/typing/typeloadModule.ml +++ b/src/typing/typeloadModule.ml @@ -734,8 +734,6 @@ let type_module ctx_from mpath file ?(dont_check_path=false) ?(is_extern=false) let timer = Timer.timer ["typing";"type_module"] in Std.finally timer (type_module ctx mpath file ~is_extern tdecls) p *) -let type_module_hook = ref (fun _ _ _ -> NoModule) - class hxb_reader_api_typeload (ctx : typer) (load_module : typer -> path -> pos -> module_def) @@ -811,7 +809,7 @@ and load_module' ctx m p = ctx.com.module_lut#find m with Not_found -> (* Check cache *) - match !type_module_hook ctx m p with + match !TypeloadCacheHook.type_module_hook ctx.com m p with | GoodModule m -> m | BinaryModule _ -> @@ -825,7 +823,7 @@ and load_module' ctx m p = let is_extern = ref false in let file, decls = try (* Try parsing *) - let rfile,decls = TypeloadParse.parse_module ctx m p in + let rfile,decls = TypeloadParse.parse_module ctx.com m p in rfile.file,decls with Not_found -> (* Nothing to parse, try loading extern type *) diff --git a/src/typing/typeloadParse.ml b/src/typing/typeloadParse.ml index eef20a8e975..238ab8ade5b 100644 --- a/src/typing/typeloadParse.ml +++ b/src/typing/typeloadParse.ml @@ -296,14 +296,14 @@ let parse_module' com m p = let pack,decls = parse_module_file com rfile p in rfile,remap,pack,decls -let parse_module ctx m p = - let rfile,remap,pack,decls = parse_module' ctx.com m p in +let parse_module com m p = + let rfile,remap,pack,decls = parse_module' com m p in if pack <> !remap then begin let spack m = if m = [] then "`package;`" else "`package " ^ (String.concat "." m) ^ ";`" in if p == null_pos then - display_error ctx.com ("Invalid commandline class : " ^ s_type_path m ^ " should be " ^ s_type_path (pack,snd m)) p + display_error com ("Invalid commandline class : " ^ s_type_path m ^ " should be " ^ s_type_path (pack,snd m)) p else - display_error ctx.com (spack pack ^ " in " ^ rfile.file ^ " should be " ^ spack (fst m)) {p with pmax = p.pmin} + display_error com (spack pack ^ " in " ^ rfile.file ^ " should be " ^ spack (fst m)) {p with pmax = p.pmin} end; rfile, if !remap <> fst m then (* build typedefs to redirect to real package *) From 8593636b73c28712d64dad0779fb8918c713fe83 Mon Sep 17 00:00:00 2001 From: Simon Krajewski Date: Fri, 2 Feb 2024 23:10:28 +0100 Subject: [PATCH 10/16] evacuate some things from typecore.ml --- src/context/typecore.ml | 96 +-------------------------------- src/core/naming.ml | 53 ++++++++++++++++++ src/typing/functionArguments.ml | 2 +- src/typing/generic.ml | 10 ++++ src/typing/strictMeta.ml | 34 ++++++++++++ src/typing/typeloadFields.ml | 2 +- src/typing/typeloadModule.ml | 4 +- 7 files changed, 102 insertions(+), 99 deletions(-) diff --git a/src/context/typecore.ml b/src/context/typecore.ml index 784717bbc9c..b57edefd001 100644 --- a/src/context/typecore.ml +++ b/src/context/typecore.ml @@ -450,58 +450,8 @@ let add_local ctx k n t p = ctx.f.locals <- PMap.add n v ctx.f.locals; v -let display_identifier_error ctx ?prepend_msg msg p = - let prepend = match prepend_msg with Some s -> s ^ " " | _ -> "" in - display_error ctx.com (prepend ^ msg) p - -let check_identifier_name ?prepend_msg ctx name kind p = - if starts_with name '$' then - display_identifier_error ctx ?prepend_msg ((StringHelper.capitalize kind) ^ " names starting with a dollar are not allowed: \"" ^ name ^ "\"") p - else if not (Lexer.is_valid_identifier name) then - display_identifier_error ctx ?prepend_msg ("\"" ^ (StringHelper.s_escape name) ^ "\" is not a valid " ^ kind ^ " name.") p - -let check_field_name ctx name p = - match name with - | "new" -> () (* the only keyword allowed in field names *) - | _ -> check_identifier_name ctx name "field" p - -let check_uppercase_identifier_name ?prepend_msg ctx name kind p = - if String.length name = 0 then - display_identifier_error ?prepend_msg ctx ((StringHelper.capitalize kind) ^ " name must not be empty.") p - else if Ast.is_lower_ident name then - display_identifier_error ?prepend_msg ctx ((StringHelper.capitalize kind) ^ " name should start with an uppercase letter: \"" ^ name ^ "\"") p - else - check_identifier_name ?prepend_msg ctx name kind p - -let check_module_path ctx (pack,name) p = - let full_path = StringHelper.s_escape (if pack = [] then name else (String.concat "." pack) ^ "." ^ name) in - check_uppercase_identifier_name ~prepend_msg:("Module \"" ^ full_path ^ "\" does not have a valid name.") ctx name "module" p; - try - List.iter (fun part -> Path.check_package_name part) pack; - with Failure msg -> - display_error_ext ctx.com (make_error - ~sub:[make_error (Custom msg) p] - (Custom ("\"" ^ (StringHelper.s_escape (String.concat "." pack)) ^ "\" is not a valid package name:")) - p - ) - -let check_local_variable_name ctx name origin p = - match name with - | "this" -> () (* TODO: vars named `this` should technically be VGenerated, not VUser *) - | _ -> - let s_var_origin origin = - match origin with - | TVOLocalVariable -> "variable" - | TVOArgument -> "function argument" - | TVOForVariable -> "for variable" - | TVOPatternVariable -> "pattern variable" - | TVOCatchVariable -> "catch variable" - | TVOLocalFunction -> "function" - in - check_identifier_name ctx name (s_var_origin origin) p - let add_local_with_origin ctx origin n t p = - check_local_variable_name ctx n origin p; + Naming.check_local_variable_name ctx.com n origin p; add_local ctx (VUser origin) n t p let gen_local_prefix = "`" @@ -594,16 +544,6 @@ let is_forced_inline c cf = let needs_inline ctx c cf = cf.cf_kind = Method MethInline && ctx.allow_inline && (ctx.g.doinline || is_forced_inline c cf) -let clone_type_parameter map path ttp = - let c = ttp.ttp_class in - let c = {c with cl_path = path} in - let def = Option.map map ttp.ttp_default in - let constraints = match ttp.ttp_constraints with - | None -> None - | Some constraints -> Some (lazy (List.map map (Lazy.force constraints))) - in - mk_type_param c ttp.ttp_host def constraints - (** checks if we can access to a given class field using current context *) let can_access ctx c cf stat = if (has_class_field_flag cf CfPublic) then @@ -739,40 +679,6 @@ let merge_core_doc ctx mt = end | _ -> ()) -let field_to_type_path com e = - let rec loop e pack name = match e with - | EField(e,f,_),p when Char.lowercase_ascii (String.get f 0) <> String.get f 0 -> (match name with - | [] | _ :: [] -> - loop e pack (f :: name) - | _ -> (* too many name paths *) - display_error com ("Unexpected " ^ f) p; - raise Exit) - | EField(e,f,_),_ -> - loop e (f :: pack) name - | EConst(Ident f),_ -> - let pack, name, sub = match name with - | [] -> - let fchar = String.get f 0 in - if Char.uppercase_ascii fchar = fchar then - pack, f, None - else begin - display_error com "A class name must start with an uppercase letter" (snd e); - raise Exit - end - | [name] -> - f :: pack, name, None - | [name; sub] -> - f :: pack, name, Some sub - | _ -> - die "" __LOC__ - in - { tpackage=pack; tname=name; tparams=[]; tsub=sub } - | _,pos -> - display_error com "Unexpected expression when building strict meta" pos; - raise Exit - in - loop e [] [] - let safe_mono_close ctx m p = try Monomorph.close m diff --git a/src/core/naming.ml b/src/core/naming.ml index 2a3b3641768..844a4a4fa8a 100644 --- a/src/core/naming.ml +++ b/src/core/naming.ml @@ -1,6 +1,8 @@ open Globals open Ast open Type +open Common +open Error (** retrieve string from @:native metadata or raise Not_found *) let get_native_name meta = @@ -84,3 +86,54 @@ let apply_native_paths t = ()) with Not_found -> () + + +let display_identifier_error com ?prepend_msg msg p = + let prepend = match prepend_msg with Some s -> s ^ " " | _ -> "" in + Common.display_error com (prepend ^ msg) p + +let check_identifier_name ?prepend_msg com name kind p = + if starts_with name '$' then + display_identifier_error com ?prepend_msg ((StringHelper.capitalize kind) ^ " names starting with a dollar are not allowed: \"" ^ name ^ "\"") p + else if not (Lexer.is_valid_identifier name) then + display_identifier_error com ?prepend_msg ("\"" ^ (StringHelper.s_escape name) ^ "\" is not a valid " ^ kind ^ " name.") p + +let check_field_name com name p = + match name with + | "new" -> () (* the only keyword allowed in field names *) + | _ -> check_identifier_name com name "field" p + +let check_uppercase_identifier_name ?prepend_msg com name kind p = + if String.length name = 0 then + display_identifier_error ?prepend_msg com ((StringHelper.capitalize kind) ^ " name must not be empty.") p + else if Ast.is_lower_ident name then + display_identifier_error ?prepend_msg com ((StringHelper.capitalize kind) ^ " name should start with an uppercase letter: \"" ^ name ^ "\"") p + else + check_identifier_name ?prepend_msg com name kind p + +let check_module_path com (pack,name) p = + let full_path = StringHelper.s_escape (if pack = [] then name else (String.concat "." pack) ^ "." ^ name) in + check_uppercase_identifier_name ~prepend_msg:("Module \"" ^ full_path ^ "\" does not have a valid name.") com name "module" p; + try + List.iter (fun part -> Path.check_package_name part) pack; + with Failure msg -> + display_error_ext com (make_error + ~sub:[make_error (Custom msg) p] + (Custom ("\"" ^ (StringHelper.s_escape (String.concat "." pack)) ^ "\" is not a valid package name:")) + p + ) + +let check_local_variable_name com name origin p = + match name with + | "this" -> () (* TODO: vars named `this` should technically be VGenerated, not VUser *) + | _ -> + let s_var_origin origin = + match origin with + | TVOLocalVariable -> "variable" + | TVOArgument -> "function argument" + | TVOForVariable -> "for variable" + | TVOPatternVariable -> "pattern variable" + | TVOCatchVariable -> "catch variable" + | TVOLocalFunction -> "function" + in + check_identifier_name com name (s_var_origin origin) p \ No newline at end of file diff --git a/src/typing/functionArguments.ml b/src/typing/functionArguments.ml index b1f8566194a..0c478ae48c6 100644 --- a/src/typing/functionArguments.ml +++ b/src/typing/functionArguments.ml @@ -100,7 +100,7 @@ object(self) loop ((v,None) :: acc) false syntax typed | ((_,pn),opt,m,_,_) :: syntax,(name,eo,t) :: typed -> delay ctx.g PTypeField (fun() -> self#check_rest (typed = []) eo opt t pn); - if not is_extern then check_local_variable_name ctx name TVOArgument pn; + if not is_extern then Naming.check_local_variable_name ctx.com name TVOArgument pn; let eo = type_function_arg_value ctx t eo do_display in let v = make_local name (VUser TVOArgument) t m pn in if do_display && DisplayPosition.display_position#enclosed_in pn then diff --git a/src/typing/generic.ml b/src/typing/generic.ml index 4f7800f4a5b..f3eb9eedc12 100644 --- a/src/typing/generic.ml +++ b/src/typing/generic.ml @@ -231,6 +231,16 @@ let build_instances ctx t p = in loop t +let clone_type_parameter map path ttp = + let c = ttp.ttp_class in + let c = {c with cl_path = path} in + let def = Option.map map ttp.ttp_default in + let constraints = match ttp.ttp_constraints with + | None -> None + | Some constraints -> Some (lazy (List.map map (Lazy.force constraints))) + in + mk_type_param c ttp.ttp_host def constraints + let clone_type_parameter gctx mg path ttp = let ttp = clone_type_parameter (generic_substitute_type gctx) path ttp in ttp.ttp_class.cl_module <- mg; diff --git a/src/typing/strictMeta.ml b/src/typing/strictMeta.ml index be91dba715b..7ed54be3742 100644 --- a/src/typing/strictMeta.ml +++ b/src/typing/strictMeta.ml @@ -124,6 +124,40 @@ let make_meta ctx texpr extra = | _ -> display_error ctx.com "Unexpected expression" texpr.epos; die "" __LOC__ +let field_to_type_path com e = + let rec loop e pack name = match e with + | EField(e,f,_),p when Char.lowercase_ascii (String.get f 0) <> String.get f 0 -> (match name with + | [] | _ :: [] -> + loop e pack (f :: name) + | _ -> (* too many name paths *) + display_error com ("Unexpected " ^ f) p; + raise Exit) + | EField(e,f,_),_ -> + loop e (f :: pack) name + | EConst(Ident f),_ -> + let pack, name, sub = match name with + | [] -> + let fchar = String.get f 0 in + if Char.uppercase_ascii fchar = fchar then + pack, f, None + else begin + display_error com "A class name must start with an uppercase letter" (snd e); + raise Exit + end + | [name] -> + f :: pack, name, None + | [name; sub] -> + f :: pack, name, Some sub + | _ -> + die "" __LOC__ + in + { tpackage=pack; tname=name; tparams=[]; tsub=sub } + | _,pos -> + display_error com "Unexpected expression when building strict meta" pos; + raise Exit + in + loop e [] [] + let get_strict_meta ctx meta params pos = let pf = ctx.com.platform in let changed_expr, fields_to_check, ctype = match params with diff --git a/src/typing/typeloadFields.ml b/src/typing/typeloadFields.ml index 43a05c888ad..9490155396d 100644 --- a/src/typing/typeloadFields.ml +++ b/src/typing/typeloadFields.ml @@ -1596,7 +1596,7 @@ let init_field (ctx,cctx,fctx) f = let name = fst f.cff_name in TypeloadCheck.check_global_metadata ctx f.cff_meta (fun m -> f.cff_meta <- m :: f.cff_meta) c.cl_module.m_path c.cl_path (Some name); let p = f.cff_pos in - if not (has_class_flag c CExtern) && not (Meta.has Meta.Native f.cff_meta) then Typecore.check_field_name ctx name p; + if not (has_class_flag c CExtern) && not (Meta.has Meta.Native f.cff_meta) then Naming.check_field_name ctx.com name p; List.iter (fun acc -> match (fst acc, f.cff_kind) with | AFinal, FProp _ when not (has_class_flag c CExtern) && ctx.com.platform <> Java -> invalid_modifier_on_property ctx.com fctx (Ast.s_placed_access acc) (snd acc) diff --git a/src/typing/typeloadModule.ml b/src/typing/typeloadModule.ml index 43092acda96..30b0d3cbe36 100644 --- a/src/typing/typeloadModule.ml +++ b/src/typing/typeloadModule.ml @@ -87,7 +87,7 @@ module ModuleLevel = struct let p = snd decl in let check_type_name type_name meta = let module_name = snd m.m_path in - if type_name <> module_name && not (Meta.has Meta.Native meta) then Typecore.check_uppercase_identifier_name ctx_m type_name "type" p; + if type_name <> module_name && not (Meta.has Meta.Native meta) then Naming.check_uppercase_identifier_name ctx_m.com type_name "type" p; in let acc = (match fst decl with | EImport _ | EUsing _ -> @@ -727,7 +727,7 @@ let type_module ctx_from mpath file ?(dont_check_path=false) ?(is_extern=false) ctx_from.com.module_lut#add m.m_path m; let tdecls = ModuleLevel.handle_import_hx ctx_from.com ctx_from.g m tdecls p in let ctx_m = type_types_into_module ctx_from.com ctx_from.g m tdecls p in - if is_extern then m.m_extra.m_kind <- MExtern else if not dont_check_path then Typecore.check_module_path ctx_m m.m_path p; + if is_extern then m.m_extra.m_kind <- MExtern else if not dont_check_path then Naming.check_module_path ctx_m.com m.m_path p; m (* let type_module ctx mpath file ?(is_extern=false) tdecls p = From 154cb5b16182ce1f15e8458345c04627d9743317 Mon Sep 17 00:00:00 2001 From: Simon Krajewski Date: Sat, 3 Feb 2024 07:11:27 +0100 Subject: [PATCH 11/16] small cleanup --- src/typing/macroContext.ml | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/src/typing/macroContext.ml b/src/typing/macroContext.ml index 6eb4eb50648..9ed0a716c91 100644 --- a/src/typing/macroContext.ml +++ b/src/typing/macroContext.ml @@ -79,16 +79,13 @@ let macro_timer com l = let typing_timer ctx need_type f = let t = Timer.timer ["typing"] in - let old = ctx.com.error_ext and oldlocals = ctx.f.locals in + let old = ctx.com.error_ext in let restore_report_mode = disable_report_mode ctx.com in - (* - disable resumable errors... unless we are in display mode (we want to reach point of completion) - *) - (* if ctx.com.display.dms_kind = DMNone then ctx.com.error <- (fun e -> raise_error e); *) (* TODO: review this... *) + let restore_field_state = TypeloadFunction.save_field_state ctx in ctx.com.error_ext <- (fun err -> raise_error { err with err_from_macro = true }); let ctx = if need_type && ctx.pass < PTypeField then begin - enter_field_typing_pass ctx.g ("typing_timer",[] (* TODO: ? *)); + enter_field_typing_pass ctx.g ("typing_timer",[]); TyperManager.clone_for_expr ctx end else ctx @@ -96,7 +93,7 @@ let typing_timer ctx need_type f = let exit() = t(); ctx.com.error_ext <- old; - ctx.f.locals <- oldlocals; + restore_field_state (); restore_report_mode (); in try From 9e0c7e45cea77d8f967cc505e772840352329b1d Mon Sep 17 00:00:00 2001 From: Simon Krajewski Date: Sat, 3 Feb 2024 17:17:49 +0100 Subject: [PATCH 12/16] add g.root_typer This gives us a nice context tree structure --- src/compiler/displayProcessing.ml | 4 +- src/context/display/displayTexpr.ml | 2 +- src/context/typecore.ml | 49 ++++++++++++---------- src/typing/macroContext.ml | 4 +- src/typing/typeloadModule.ml | 65 +++++++++++++++-------------- src/typing/typerEntry.ml | 3 +- 6 files changed, 66 insertions(+), 61 deletions(-) diff --git a/src/compiler/displayProcessing.ml b/src/compiler/displayProcessing.ml index d2dde9cef58..7e345a0f8e6 100644 --- a/src/compiler/displayProcessing.ml +++ b/src/compiler/displayProcessing.ml @@ -239,7 +239,7 @@ let load_display_file_standalone (ctx : Typecore.typer) file = let dir = ExtString.String.join (if path.backslash then "\\" else "/") parts in com.class_paths#add (new ClassPath.directory_class_path dir User) end; - ignore(TypeloadModule.type_module ctx (pack,name) file ~dont_check_path:true decls null_pos) + ignore(TypeloadModule.type_module ctx.com ctx.g (pack,name) file ~dont_check_path:true decls null_pos) let load_display_content_standalone (ctx : Typecore.typer) input = let com = ctx.com in @@ -247,7 +247,7 @@ let load_display_content_standalone (ctx : Typecore.typer) input = let p = {pfile = file; pmin = 0; pmax = 0} in let parsed = TypeloadParse.parse_file_from_string com file p input in let pack,decls = TypeloadParse.handle_parser_result com p parsed in - ignore(TypeloadModule.type_module ctx (pack,"?DISPLAY") file ~dont_check_path:true decls p) + ignore(TypeloadModule.type_module ctx.com ctx.g (pack,"?DISPLAY") file ~dont_check_path:true decls p) (* 4. Display processing before typing *) diff --git a/src/context/display/displayTexpr.ml b/src/context/display/displayTexpr.ml index 93d9f2a9f65..bdd8e72b7a4 100644 --- a/src/context/display/displayTexpr.ml +++ b/src/context/display/displayTexpr.ml @@ -176,7 +176,7 @@ let check_display_file ctx cs = begin match !TypeloadCacheHook.type_module_hook ctx.com path null_pos with | NoModule | BadModule _ -> raise Not_found | BinaryModule mc -> - let api = (new TypeloadModule.hxb_reader_api_typeload ctx TypeloadModule.load_module' p :> HxbReaderApi.hxb_reader_api) in + let api = (new TypeloadModule.hxb_reader_api_typeload ctx.com ctx.g TypeloadModule.load_module' p :> HxbReaderApi.hxb_reader_api) in let reader = new HxbReader.hxb_reader path ctx.com.hxb_reader_stats in let m = reader#read_chunks api mc.mc_chunks in m diff --git a/src/context/typecore.ml b/src/context/typecore.ml index 6ff83a794b2..49b2f35ad7e 100644 --- a/src/context/typecore.ml +++ b/src/context/typecore.ml @@ -125,6 +125,7 @@ type typer_globals = { mutable build_count : int; mutable t_dynamic_def : Type.t; mutable delayed_display : DisplayTypes.display_exception_kind option; + root_typer : typer; (* api *) do_macro : typer -> macro_mode -> path -> string -> expr list -> pos -> macro_result; do_load_macro : typer -> bool -> path -> string -> pos -> ((string * bool * t) list * t * tclass * Type.tclass_field); @@ -183,20 +184,22 @@ and monomorphs = { } module TyperManager = struct - let create com g m c f e pass params = { - com = com; - g = g; - t = com.basic; - m = m; - c = c; - f = f; - e = e; - pass = pass; - allow_inline = true; - allow_transform = true; - type_params = params; - memory_marker = memory_marker; - } + let create ctx m c f e pass params = + let new_ctx = { + com = ctx.com; + g = ctx.g; + t = ctx.com.basic; + m = m; + c = c; + f = f; + e = e; + pass = pass; + allow_inline = true; + allow_transform = true; + type_params = params; + memory_marker = memory_marker; + } in + new_ctx let create_ctx_c c = { @@ -240,50 +243,50 @@ module TyperManager = struct macro_depth = 0; } - let create_for_module com g m = + let clone_for_module ctx m = let c = create_ctx_c null_class in let f = create_ctx_f null_field in let e = create_ctx_e () in - create com g m c f e PBuildModule [] + create ctx m c f e PBuildModule [] let clone_for_class ctx c = let c = create_ctx_c c in let f = create_ctx_f null_field in let e = create_ctx_e () in let params = match c.curclass.cl_kind with KAbstractImpl a -> a.a_params | _ -> c.curclass.cl_params in - create ctx.com ctx.g ctx.m c f e PBuildClass params + create ctx ctx.m c f e PBuildClass params let clone_for_enum ctx en = let c = create_ctx_c null_class in let f = create_ctx_f null_field in let e = create_ctx_e () in - create ctx.com ctx.g ctx.m c f e PBuildModule en.e_params + create ctx ctx.m c f e PBuildModule en.e_params let clone_for_typedef ctx td = let c = create_ctx_c null_class in let f = create_ctx_f null_field in let e = create_ctx_e () in - create ctx.com ctx.g ctx.m c f e PBuildModule td.t_params + create ctx ctx.m c f e PBuildModule td.t_params let clone_for_abstract ctx a = let c = create_ctx_c null_class in let f = create_ctx_f null_field in let e = create_ctx_e () in - create ctx.com ctx.g ctx.m c f e PBuildModule a.a_params + create ctx ctx.m c f e PBuildModule a.a_params let clone_for_field ctx cf params = let f = create_ctx_f cf in let e = create_ctx_e () in - create ctx.com ctx.g ctx.m ctx.c f e PBuildClass params + create ctx ctx.m ctx.c f e PBuildClass params let clone_for_enum_field ctx params = let f = create_ctx_f null_field in let e = create_ctx_e () in - create ctx.com ctx.g ctx.m ctx.c f e PBuildClass params + create ctx ctx.m ctx.c f e PBuildClass params let clone_for_expr ctx = let e = create_ctx_e () in - create ctx.com ctx.g ctx.m ctx.c ctx.f e PTypeField ctx.type_params + create ctx ctx.m ctx.c ctx.f e PTypeField ctx.type_params end type field_host = diff --git a/src/typing/macroContext.ml b/src/typing/macroContext.ml index 4cf029f78e9..29f50e2aec0 100644 --- a/src/typing/macroContext.ml +++ b/src/typing/macroContext.ml @@ -462,7 +462,7 @@ let make_macro_api ctx mctx p = in let add is_macro ctx = let mdep = Option.map_default (fun s -> TypeloadModule.load_module ctx (parse_path s) pos) ctx.m.curmod mdep in - let mnew = TypeloadModule.type_module ctx ~dont_check_path:(has_native_meta) m (Path.UniqueKey.lazy_path mdep.m_extra.m_file) [tdef,pos] pos in + let mnew = TypeloadModule.type_module ctx.com ctx.g ~dont_check_path:(has_native_meta) m (Path.UniqueKey.lazy_path mdep.m_extra.m_file) [tdef,pos] pos in mnew.m_extra.m_kind <- if is_macro then MMacro else MFake; add_dependency mnew mdep; ctx.com.module_nonexistent_lut#clear; @@ -492,7 +492,7 @@ let make_macro_api ctx mctx p = let m = ctx.com.module_lut#find mpath in ignore(TypeloadModule.type_types_into_module ctx.com ctx.g m types pos) with Not_found -> - let mnew = TypeloadModule.type_module ctx mpath (Path.UniqueKey.lazy_path ctx.m.curmod.m_extra.m_file) types pos in + let mnew = TypeloadModule.type_module ctx.com ctx.g mpath (Path.UniqueKey.lazy_path ctx.m.curmod.m_extra.m_file) types pos in mnew.m_extra.m_kind <- MFake; add_dependency mnew ctx.m.curmod; ctx.com.module_nonexistent_lut#clear; diff --git a/src/typing/typeloadModule.ml b/src/typing/typeloadModule.ml index e2bdc25e1bc..6059f7d3c19 100644 --- a/src/typing/typeloadModule.ml +++ b/src/typing/typeloadModule.ml @@ -692,7 +692,7 @@ let make_curmod com g m = Creates a module context for [m] and types [tdecls] using it. *) let type_types_into_module com g m tdecls p = - let ctx_m = TyperManager.create_for_module com g (make_curmod com g m) in + let ctx_m = TyperManager.clone_for_module g.root_typer (make_curmod com g m) in let decls,tdecls = ModuleLevel.create_module_types ctx_m m tdecls p in let types = List.map fst decls in (* During the initial module_lut#add in type_module, m has no m_types yet by design. @@ -716,11 +716,11 @@ let type_types_into_module com g m tdecls p = (* Creates a new module and types [tdecls] into it. *) -let type_module ctx_from mpath file ?(dont_check_path=false) ?(is_extern=false) tdecls p = - let m = ModuleLevel.make_module ctx_from.com ctx_from.g mpath file p in - ctx_from.com.module_lut#add m.m_path m; - let tdecls = ModuleLevel.handle_import_hx ctx_from.com ctx_from.g m tdecls p in - let ctx_m = type_types_into_module ctx_from.com ctx_from.g m tdecls p in +let type_module com g mpath file ?(dont_check_path=false) ?(is_extern=false) tdecls p = + let m = ModuleLevel.make_module com g mpath file p in + com.module_lut#add m.m_path m; + let tdecls = ModuleLevel.handle_import_hx com g m tdecls p in + let ctx_m = type_types_into_module com g m tdecls p in if is_extern then m.m_extra.m_kind <- MExtern else if not dont_check_path then Naming.check_module_path ctx_m.com m.m_path p; m @@ -729,27 +729,28 @@ let type_module ctx_from mpath file ?(dont_check_path=false) ?(is_extern=false) Std.finally timer (type_module ctx mpath file ~is_extern tdecls) p *) class hxb_reader_api_typeload - (ctx : typer) - (load_module : typer -> path -> pos -> module_def) + (com : context) + (g : typer_globals) + (load_module : context -> typer_globals -> path -> pos -> module_def) (p : pos) = object(self) method make_module (path : path) (file : string) = - let m = ModuleLevel.make_module ctx.com ctx.g path file p in + let m = ModuleLevel.make_module com g path file p in m.m_extra.m_processed <- 1; m method add_module (m : module_def) = - ctx.com.module_lut#add m.m_path m + com.module_lut#add m.m_path m method resolve_type (pack : string list) (mname : string) (tname : string) = - let m = load_module ctx (pack,mname) p in + let m = load_module com g (pack,mname) p in List.find (fun t -> snd (t_path t) = tname) m.m_types method resolve_module (path : path) = - load_module ctx path p + load_module com g path p method basic_types = - ctx.com.basic + com.basic method get_var_id (i : int) = (* The v_id in .hxb has no relation to this context, make a new one. *) @@ -758,22 +759,22 @@ class hxb_reader_api_typeload !uid method read_expression_eagerly (cf : tclass_field) = - ctx.com.is_macro_context || match cf.cf_kind with + com.is_macro_context || match cf.cf_kind with | Var _ -> true | Method _ -> - delay ctx.g PTypeField (fun () -> ignore(follow cf.cf_type)); + delay g PTypeField (fun () -> ignore(follow cf.cf_type)); false end -let rec load_hxb_module ctx path p = +let rec load_hxb_module com g path p = let read file bytes = try - let api = (new hxb_reader_api_typeload ctx load_module' p :> HxbReaderApi.hxb_reader_api) in - let reader = new HxbReader.hxb_reader path ctx.com.hxb_reader_stats in + let api = (new hxb_reader_api_typeload com g load_module' p :> HxbReaderApi.hxb_reader_api) in + let reader = new HxbReader.hxb_reader path com.hxb_reader_stats in let read = reader#read api bytes in let m = read EOT in - delay ctx.g PConnectField (fun () -> + delay g PConnectField (fun () -> ignore(read EOM); ); m @@ -783,7 +784,7 @@ let rec load_hxb_module ctx path p = Printf.eprintf " => %s\n%s\n" msg stack; raise e in - let target = Common.platform_name_macro ctx.com in + let target = Common.platform_name_macro com in let rec loop l = match l with | hxb_lib :: l -> begin match hxb_lib#get_bytes target path with @@ -795,35 +796,35 @@ let rec load_hxb_module ctx path p = | [] -> raise Not_found in - loop ctx.com.hxb_libs + loop com.hxb_libs -and load_module' ctx m p = +and load_module' com g m p = try (* Check current context *) - ctx.com.module_lut#find m + com.module_lut#find m with Not_found -> (* Check cache *) - match !TypeloadCacheHook.type_module_hook ctx.com m p with + match !TypeloadCacheHook.type_module_hook com m p with | GoodModule m -> m | BinaryModule _ -> die "" __LOC__ (* The server builds those *) | NoModule | BadModule _ -> try - load_hxb_module ctx m p + load_hxb_module com g m p with Not_found -> let raise_not_found () = raise_error_msg (Module_not_found m) p in - if ctx.com.module_nonexistent_lut#mem m then raise_not_found(); - if ctx.g.load_only_cached_modules then raise_not_found(); + if com.module_nonexistent_lut#mem m then raise_not_found(); + if g.load_only_cached_modules then raise_not_found(); let is_extern = ref false in let file, decls = try (* Try parsing *) - let rfile,decls = TypeloadParse.parse_module ctx.com m p in + let rfile,decls = TypeloadParse.parse_module com m p in rfile.file,decls with Not_found -> (* Nothing to parse, try loading extern type *) let rec loop = function | [] -> - ctx.com.module_nonexistent_lut#add m true; + com.module_nonexistent_lut#add m true; raise_not_found() | (file,load) :: l -> match load m p with @@ -831,13 +832,13 @@ and load_module' ctx m p = | Some (_,a) -> file, a in is_extern := true; - loop ctx.com.load_extern_type + loop com.load_extern_type in let is_extern = !is_extern in - type_module ctx m file ~is_extern decls p + type_module com g m file ~is_extern decls p let load_module ctx m p = - let m2 = load_module' ctx m p in + let m2 = load_module' ctx.com ctx.g m p in add_dependency ~skip_postprocess:true ctx.m.curmod m2; if ctx.pass = PTypeField then flush_pass ctx.g PConnectField ("load_module",fst m @ [snd m]); m2 diff --git a/src/typing/typerEntry.ml b/src/typing/typerEntry.ml index 72ae8d3bf57..e1c9aec34f9 100644 --- a/src/typing/typerEntry.ml +++ b/src/typing/typerEntry.ml @@ -7,7 +7,7 @@ open Resolution open Error let create com macros = - let ctx = { + let rec ctx = { com = com; t = com.basic; g = { @@ -36,6 +36,7 @@ let create com macros = do_format_string = format_string; do_load_core_class = Typeload.load_core_class; delayed_display = None; + root_typer = ctx; }; m = { curmod = null_module; From d7e848a25482c9bb5ced18e8e5b082766bdcf0ec Mon Sep 17 00:00:00 2001 From: Simon Krajewski Date: Sat, 3 Feb 2024 22:15:55 +0100 Subject: [PATCH 13/16] remove more { ctx with and assert order --- src/context/typecore.ml | 33 +++++++++++++++++++++------------ src/typing/generic.ml | 5 ++++- src/typing/typeload.ml | 5 +++-- 3 files changed, 28 insertions(+), 15 deletions(-) diff --git a/src/context/typecore.ml b/src/context/typecore.ml index 49b2f35ad7e..110e897e1a5 100644 --- a/src/context/typecore.ml +++ b/src/context/typecore.ml @@ -183,8 +183,18 @@ and monomorphs = { mutable perfunction : (tmono * pos) list; } +let pass_name = function + | PBuildModule -> "build-module" + | PBuildClass -> "build-class" + | PConnectField -> "connect-field" + | PTypeField -> "type-field" + | PCheckConstraint -> "check-constraint" + | PForce -> "force" + | PFinal -> "final" + module TyperManager = struct let create ctx m c f e pass params = + if pass < ctx.pass then die (Printf.sprintf "Bad context clone from %s(%s) to %s(%s)" (s_type_path ctx.m.curmod.m_path) (pass_name ctx.pass) (s_type_path m.curmod.m_path) (pass_name pass)) __LOC__; let new_ctx = { com = ctx.com; g = ctx.g; @@ -260,19 +270,19 @@ module TyperManager = struct let c = create_ctx_c null_class in let f = create_ctx_f null_field in let e = create_ctx_e () in - create ctx ctx.m c f e PBuildModule en.e_params + create ctx ctx.m c f e PBuildClass en.e_params let clone_for_typedef ctx td = let c = create_ctx_c null_class in let f = create_ctx_f null_field in let e = create_ctx_e () in - create ctx ctx.m c f e PBuildModule td.t_params + create ctx ctx.m c f e PBuildClass td.t_params let clone_for_abstract ctx a = let c = create_ctx_c null_class in let f = create_ctx_f null_field in let e = create_ctx_e () in - create ctx ctx.m c f e PBuildModule a.a_params + create ctx ctx.m c f e PBuildClass a.a_params let clone_for_field ctx cf params = let f = create_ctx_f cf in @@ -287,6 +297,14 @@ module TyperManager = struct let clone_for_expr ctx = let e = create_ctx_e () in create ctx ctx.m ctx.c ctx.f e PTypeField ctx.type_params + + let clone_for_type_params ctx params = + create ctx ctx.m ctx.c ctx.f ctx.e ctx.pass params + + let clone_for_type_parameter_expression ctx = + let f = create_ctx_f ctx.f.curfield in + let e = create_ctx_e () in + create ctx ctx.m ctx.c f e PTypeField ctx.type_params end type field_host = @@ -351,15 +369,6 @@ let type_generic_function_ref : (typer -> field_access -> (unit -> texpr) field_ let create_context_ref : (Common.context -> ((unit -> unit) * typer) option -> typer) ref = ref (fun _ -> assert false) -let pass_name = function - | PBuildModule -> "build-module" - | PBuildClass -> "build-class" - | PConnectField -> "connect-field" - | PTypeField -> "type-field" - | PCheckConstraint -> "check-constraint" - | PForce -> "force" - | PFinal -> "final" - let warning ?(depth=0) ctx w msg p = let options = (Warning.from_meta ctx.c.curclass.cl_meta) @ (Warning.from_meta ctx.f.curfield.cf_meta) in match Warning.get_mode w options with diff --git a/src/typing/generic.ml b/src/typing/generic.ml index f3eb9eedc12..a0eebd9e8c3 100644 --- a/src/typing/generic.ml +++ b/src/typing/generic.ml @@ -26,7 +26,8 @@ let make_generic ctx ps pt debug p = begin match c.cl_kind with | KExpr e -> let name = ident_safe (Ast.Printer.s_expr e) in - let e = type_expr {ctx with f = {ctx.f with locals = PMap.empty}} e WithType.value in + let ctx = TyperManager.clone_for_type_parameter_expression ctx in + let e = type_expr ctx e WithType.value in name,(t,Some e) | _ -> ((ident_safe (s_type_path_underscore c.cl_path)) ^ (loop_tl top tl),(t,None)) @@ -298,8 +299,10 @@ let build_generic_class ctx c p tl = m_statics = None; m_extra = module_extra (s_type_path (pack,name)) m.m_extra.m_sign 0. MFake gctx.ctx.com.compilation_step m.m_extra.m_check_policy; } in + let ctx = TyperManager.clone_for_module ctx.g.root_typer (TypeloadModule.make_curmod ctx.com ctx.g mg) in gctx.mg <- Some mg; let cg = mk_class mg (pack,name) c.cl_pos c.cl_name_pos in + let ctx = TyperManager.clone_for_class ctx c in cg.cl_meta <- List.filter (fun (m,_,_) -> match m with | Meta.Access | Allow | Final diff --git a/src/typing/typeload.ml b/src/typing/typeload.ml index fc8201b5648..5a2c33f0a52 100644 --- a/src/typing/typeload.ml +++ b/src/typing/typeload.ml @@ -279,7 +279,8 @@ let check_param_constraints ctx t map ttp p = in match follow t with | TInst({cl_kind = KExpr e},_) -> - let e = type_expr {ctx with f = {ctx.f with locals = PMap.empty}} e (WithType.with_type ti) in + let ctx = TyperManager.clone_for_type_parameter_expression ctx in + let e = type_expr ctx e (WithType.with_type ti) in begin try unify_raise e.etype ti p with Error { err_message = Unify _ } -> fail() end | _ -> @@ -739,7 +740,7 @@ and type_type_params ctx host path p tpl = tp,type_type_param ctx host path p tp ) tpl in let params = List.map snd param_pairs in - let ctx = { ctx with type_params = params @ ctx.type_params } in + let ctx = TyperManager.clone_for_type_params ctx (params @ ctx.type_params) in List.iter (fun (tp,ttp) -> begin match tp.tp_default with | None -> From 491e0a73d6652ce22e69ac3dff1a4574bc9f05c7 Mon Sep 17 00:00:00 2001 From: Simon Krajewski Date: Sun, 4 Feb 2024 08:36:59 +0100 Subject: [PATCH 14/16] less mutability and cloning --- src/context/typecore.ml | 37 ++++++++++++++-------------------- src/typing/macroContext.ml | 2 +- src/typing/typeloadFields.ml | 34 +++++++++++++------------------ src/typing/typeloadFunction.ml | 12 +++++------ src/typing/typer.ml | 4 ++-- src/typing/typerEntry.ml | 2 +- 6 files changed, 38 insertions(+), 53 deletions(-) diff --git a/src/context/typecore.ml b/src/context/typecore.ml index 110e897e1a5..320e1a07974 100644 --- a/src/context/typecore.ml +++ b/src/context/typecore.ml @@ -139,11 +139,11 @@ type typer_globals = { (* typer_expr holds information that is specific to a (function) expresssion, whereas typer_field is shared by local TFunctions. *) and typer_expr = { + curfun : current_fun; + in_function : bool; mutable ret : t; - mutable curfun : current_fun; mutable opened : anon_status ref list; mutable monomorphs : monomorphs; - mutable in_function : bool; mutable in_loop : bool; mutable bypass_accessor : int; mutable with_type_stack : WithType.t list; @@ -237,12 +237,12 @@ module TyperManager = struct in_call_args = false; } - let create_ctx_e () = + let create_ctx_e curfun in_function = { + curfun; + in_function; ret = t_dynamic; - curfun = FunStatic; opened = []; - in_function = false; monomorphs = { perfunction = []; }; @@ -256,46 +256,39 @@ module TyperManager = struct let clone_for_module ctx m = let c = create_ctx_c null_class in let f = create_ctx_f null_field in - let e = create_ctx_e () in - create ctx m c f e PBuildModule [] + create ctx m c f ctx.e PBuildModule [] let clone_for_class ctx c = let c = create_ctx_c c in let f = create_ctx_f null_field in - let e = create_ctx_e () in let params = match c.curclass.cl_kind with KAbstractImpl a -> a.a_params | _ -> c.curclass.cl_params in - create ctx ctx.m c f e PBuildClass params + create ctx ctx.m c f ctx.e PBuildClass params let clone_for_enum ctx en = let c = create_ctx_c null_class in let f = create_ctx_f null_field in - let e = create_ctx_e () in - create ctx ctx.m c f e PBuildClass en.e_params + create ctx ctx.m c f ctx.e PBuildClass en.e_params let clone_for_typedef ctx td = let c = create_ctx_c null_class in let f = create_ctx_f null_field in - let e = create_ctx_e () in - create ctx ctx.m c f e PBuildClass td.t_params + create ctx ctx.m c f ctx.e PBuildClass td.t_params let clone_for_abstract ctx a = let c = create_ctx_c null_class in let f = create_ctx_f null_field in - let e = create_ctx_e () in - create ctx ctx.m c f e PBuildClass a.a_params + create ctx ctx.m c f ctx.e PBuildClass a.a_params let clone_for_field ctx cf params = let f = create_ctx_f cf in - let e = create_ctx_e () in - create ctx ctx.m ctx.c f e PBuildClass params + create ctx ctx.m ctx.c f ctx.e PBuildClass params let clone_for_enum_field ctx params = let f = create_ctx_f null_field in - let e = create_ctx_e () in - create ctx ctx.m ctx.c f e PBuildClass params + create ctx ctx.m ctx.c f ctx.e PBuildClass params - let clone_for_expr ctx = - let e = create_ctx_e () in + let clone_for_expr ctx curfun in_function = + let e = create_ctx_e curfun in_function in create ctx ctx.m ctx.c ctx.f e PTypeField ctx.type_params let clone_for_type_params ctx params = @@ -303,7 +296,7 @@ module TyperManager = struct let clone_for_type_parameter_expression ctx = let f = create_ctx_f ctx.f.curfield in - let e = create_ctx_e () in + let e = create_ctx_e ctx.e.curfun false in create ctx ctx.m ctx.c f e PTypeField ctx.type_params end diff --git a/src/typing/macroContext.ml b/src/typing/macroContext.ml index 29f50e2aec0..65b831ad254 100644 --- a/src/typing/macroContext.ml +++ b/src/typing/macroContext.ml @@ -64,7 +64,7 @@ let typing_timer ctx need_type f = let ctx = if need_type && ctx.pass < PTypeField then begin enter_field_typing_pass ctx.g ("typing_timer",[]); - TyperManager.clone_for_expr ctx + TyperManager.clone_for_expr ctx ctx.e.curfun false end else ctx in diff --git a/src/typing/typeloadFields.ml b/src/typing/typeloadFields.ml index 98a604258f5..0a2465b99e2 100644 --- a/src/typing/typeloadFields.ml +++ b/src/typing/typeloadFields.ml @@ -607,7 +607,6 @@ let transform_field (ctx,cctx) c f fields p = f let type_var_field ctx t e stat do_display p = - if stat then ctx.e.curfun <- FunStatic else ctx.e.curfun <- FunMember; let e = if do_display then Display.preprocess_expr ctx.com e else e in let e = type_expr ctx e (WithType.with_type t) in let e = AbstractCast.cast_or_unify ctx t e p in @@ -744,7 +743,7 @@ module TypeBinding = struct let c = cctx.tclass in let t = cf.cf_type in let p = cf.cf_pos in - let ctx = TyperManager.clone_for_expr ctx_f in + let ctx = TyperManager.clone_for_expr ctx_f (if fctx.is_static then FunStatic else FunMember) false in if (has_class_flag c CInterface) then unexpected_expression ctx.com fctx "Initialization on field of interface" (pos e); cf.cf_meta <- ((Meta.Value,[e],null_pos) :: cf.cf_meta); let check_cast e = @@ -835,18 +834,12 @@ module TypeBinding = struct | Some e -> bind_var_expression ctx cctx fctx cf e - let bind_method ctx_f cctx fctx cf t args ret e p = + let bind_method ctx_f cctx fctx fmode cf t args ret e p = let c = cctx.tclass in - let ctx = TyperManager.clone_for_expr ctx_f in + let ctx = TyperManager.clone_for_expr ctx_f fmode true in let bind r = incr stats.s_methods_typed; if (Meta.has (Meta.Custom ":debug.typing") (c.cl_meta @ cf.cf_meta)) then ctx.com.print (Printf.sprintf "Typing method %s.%s\n" (s_type_path c.cl_path) cf.cf_name); - let fmode = (match cctx.abstract with - | Some _ -> - if fctx.is_abstract_member then FunMemberAbstract else FunStatic - | None -> - if fctx.field_kind = CfrConstructor then FunConstructor else if fctx.is_static then FunStatic else FunMember - ) in begin match ctx.com.platform with | Java when is_java_native_function ctx cf.cf_meta cf.cf_pos -> if e <> None then @@ -870,7 +863,7 @@ module TypeBinding = struct | _ -> (fun () -> ()) in - let e = TypeloadFunction.type_function ctx args ret fmode e fctx.is_display_field p in + let e = TypeloadFunction.type_function ctx args ret e fctx.is_display_field p in f_check(); (* Disabled for now, see https://github.com/HaxeFoundation/haxe/issues/3033 *) (* List.iter (fun (v,_) -> @@ -1334,27 +1327,28 @@ let create_method (ctx,cctx,fctx) c f fd p = () ) parent; generate_args_meta ctx.com (Some c) (fun meta -> cf.cf_meta <- meta :: cf.cf_meta) fd.f_args; - begin match cctx.abstract with - | Some a -> - check_abstract (ctx,cctx,fctx) a c cf fd t ret p; - | _ -> - () - end; + let fmode = match cctx.abstract with + | Some a -> + check_abstract (ctx,cctx,fctx) a c cf fd t ret p; + if fctx.is_abstract_member then FunMemberAbstract else FunStatic + | _ -> + if fctx.field_kind = CfrConstructor then FunConstructor else if fctx.is_static then FunStatic else FunMember + in init_meta_overloads ctx (Some c) cf; ctx.f.curfield <- cf; if fctx.do_bind then - TypeBinding.bind_method ctx cctx fctx cf t args ret fd.f_expr (match fd.f_expr with Some e -> snd e | None -> f.cff_pos) + TypeBinding.bind_method ctx cctx fctx fmode cf t args ret fd.f_expr (match fd.f_expr with Some e -> snd e | None -> f.cff_pos) else begin if fctx.is_display_field then begin delay ctx.g PTypeField (fun () -> (* We never enter type_function so we're missing out on the argument processing there. Let's do it here. *) - let ctx = TyperManager.clone_for_expr ctx in + let ctx = TyperManager.clone_for_expr ctx fmode true in ignore(args#for_expr ctx) ); check_field_display ctx fctx c cf; end else delay ctx.g PTypeField (fun () -> - let ctx = TyperManager.clone_for_expr ctx in + let ctx = TyperManager.clone_for_expr ctx fmode true in args#verify_extern ctx ); if fd.f_expr <> None then begin diff --git a/src/typing/typeloadFunction.ml b/src/typing/typeloadFunction.ml index 14aca0ba064..536e14cf0af 100644 --- a/src/typing/typeloadFunction.ml +++ b/src/typing/typeloadFunction.ml @@ -36,9 +36,7 @@ let save_field_state ctx = let type_function_params ctx fd host fname p = Typeload.type_type_params ctx host ([],fname) p fd.f_params -let type_function ctx (args : function_arguments) ret fmode e do_display p = - ctx.e.in_function <- true; - ctx.e.curfun <- fmode; +let type_function ctx (args : function_arguments) ret e do_display p = ctx.e.ret <- ret; ctx.e.opened <- []; ctx.e.monomorphs.perfunction <- []; @@ -53,7 +51,7 @@ let type_function ctx (args : function_arguments) ret fmode e do_display p = *) EBlock [],p else - if fmode = FunMember && has_class_flag ctx.c.curclass CAbstract then + if ctx.e.curfun = FunMember && has_class_flag ctx.c.curclass CAbstract then raise_typing_error "Function body or abstract modifier required" p else raise_typing_error "Function body required" p @@ -110,7 +108,7 @@ let type_function ctx (args : function_arguments) ret fmode e do_display p = with Not_found -> None in - let e = if fmode <> FunConstructor then + let e = if ctx.e.curfun <> FunConstructor then e else begin delay ctx.g PForce (fun () -> TypeloadCheck.check_final_vars ctx e); @@ -163,9 +161,9 @@ let type_function ctx (args : function_arguments) ret fmode e do_display p = if is_position_debug then print_endline ("typing:\n" ^ (Texpr.dump_with_pos "" e)); e -let type_function ctx args ret fmode e do_display p = +let type_function ctx args ret e do_display p = let save = save_field_state ctx in - Std.finally save (type_function ctx args ret fmode e do_display) p + Std.finally save (type_function ctx args ret e do_display) p let add_constructor ctx_c c force_constructor p = if c.cl_constructor <> None then () else diff --git a/src/typing/typer.ml b/src/typing/typer.ml index 1ad869b5b5f..904a22be727 100644 --- a/src/typing/typer.ml +++ b/src/typing/typer.ml @@ -1233,7 +1233,7 @@ and type_local_function ctx_from kind f with_type p = | FunMemberAbstractLocal -> FunMemberAbstractLocal | _ -> FunMemberClassLocal in - let ctx = TyperManager.clone_for_expr ctx_from in + let ctx = TyperManager.clone_for_expr ctx_from curfun true in let old_tp = ctx.type_params in ctx.type_params <- params @ ctx.type_params; if not inline then ctx.e.in_loop <- false; @@ -1337,7 +1337,7 @@ and type_local_function ctx_from kind f with_type p = if params <> [] then v.v_extra <- Some (var_extra params None); Some v ) in - let e = TypeloadFunction.type_function ctx args rt curfun f.f_expr ctx.f.in_display p in + let e = TypeloadFunction.type_function ctx args rt f.f_expr ctx.f.in_display p in ctx.type_params <- old_tp; let tf = { tf_args = args#for_expr ctx; diff --git a/src/typing/typerEntry.ml b/src/typing/typerEntry.ml index e1c9aec34f9..f088234bd33 100644 --- a/src/typing/typerEntry.ml +++ b/src/typing/typerEntry.ml @@ -53,7 +53,7 @@ let create com macros = get_build_infos = (fun() -> None); }; f = TyperManager.create_ctx_f null_field; - e = TyperManager.create_ctx_e (); + e = TyperManager.create_ctx_e FunStatic false; pass = PBuildModule; allow_inline = true; allow_transform = true; From 790af65c12a4807151c4c5ff22764c4fa567e5da Mon Sep 17 00:00:00 2001 From: Simon Krajewski Date: Sun, 4 Feb 2024 08:41:58 +0100 Subject: [PATCH 15/16] even less cloning --- src/context/typecore.ml | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) diff --git a/src/context/typecore.ml b/src/context/typecore.ml index 320e1a07974..9b9ac8fe6c4 100644 --- a/src/context/typecore.ml +++ b/src/context/typecore.ml @@ -254,30 +254,24 @@ module TyperManager = struct } let clone_for_module ctx m = - let c = create_ctx_c null_class in - let f = create_ctx_f null_field in - create ctx m c f ctx.e PBuildModule [] + create ctx m ctx.c ctx.f ctx.e PBuildModule [] let clone_for_class ctx c = let c = create_ctx_c c in - let f = create_ctx_f null_field in let params = match c.curclass.cl_kind with KAbstractImpl a -> a.a_params | _ -> c.curclass.cl_params in - create ctx ctx.m c f ctx.e PBuildClass params + create ctx ctx.m c ctx.f ctx.e PBuildClass params let clone_for_enum ctx en = let c = create_ctx_c null_class in - let f = create_ctx_f null_field in - create ctx ctx.m c f ctx.e PBuildClass en.e_params + create ctx ctx.m c ctx.f ctx.e PBuildClass en.e_params let clone_for_typedef ctx td = let c = create_ctx_c null_class in - let f = create_ctx_f null_field in - create ctx ctx.m c f ctx.e PBuildClass td.t_params + create ctx ctx.m c ctx.f ctx.e PBuildClass td.t_params let clone_for_abstract ctx a = let c = create_ctx_c null_class in - let f = create_ctx_f null_field in - create ctx ctx.m c f ctx.e PBuildClass a.a_params + create ctx ctx.m c ctx.f ctx.e PBuildClass a.a_params let clone_for_field ctx cf params = let f = create_ctx_f cf in From 9d5aa0661929ea9e0f66b636a7a989953399fa86 Mon Sep 17 00:00:00 2001 From: Simon Krajewski Date: Mon, 5 Feb 2024 08:41:03 +0100 Subject: [PATCH 16/16] fix allow_inline again --- src/context/typecore.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/context/typecore.ml b/src/context/typecore.ml index 3536f4f3374..a530d735fe5 100644 --- a/src/context/typecore.ml +++ b/src/context/typecore.ml @@ -204,8 +204,8 @@ module TyperManager = struct f = f; e = e; pass = pass; - allow_inline = true; - allow_transform = true; + allow_inline = ctx.allow_inline; + allow_transform = ctx.allow_transform; type_params = params; memory_marker = memory_marker; } in