From 9e0c7e45cea77d8f967cc505e772840352329b1d Mon Sep 17 00:00:00 2001 From: Simon Krajewski Date: Sat, 3 Feb 2024 17:17:49 +0100 Subject: [PATCH] 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;