diff --git a/src/compiler/compilationCache.ml b/src/compiler/compilationCache.ml index bbbd45525d3..a4408122e4c 100644 --- a/src/compiler/compilationCache.ml +++ b/src/compiler/compilationCache.ml @@ -144,17 +144,28 @@ class cache = object(self) (* contexts *) + method create_context sign = + let cache = new context_cache (Hashtbl.length contexts) sign in + context_list <- cache :: context_list; + Hashtbl.add contexts sign cache; + cache + + method get_or_create_context sign = + match Hashtbl.find_opt contexts sign with + | None -> self#create_context sign + | Some cache -> cache + method get_context sign = try Hashtbl.find contexts sign with Not_found -> - let cache = new context_cache (Hashtbl.length contexts) sign in - context_list <- cache :: context_list; - Hashtbl.add contexts sign cache; - cache + trace_call_stack (); + assert false method add_info sign desc platform class_path defines = - let cc = self#get_context sign in + (* TODO context should probably already exist at this point? *) + (* let cc = self#get_context sign in *) + let cc = self#get_or_create_context sign in let jo = JObject [ "index",JInt cc#get_index; "desc",JString desc; diff --git a/src/compiler/server.ml b/src/compiler/server.ml index 4a3fad9dd19..50a3ff4d62b 100644 --- a/src/compiler/server.ml +++ b/src/compiler/server.ml @@ -221,7 +221,20 @@ let get_changed_directories sctx (ctx : Typecore.typer) = dirs let find_or_restore_module cs sign ctx path = - HxbRestore.find cs sign ctx.Typecore.com path + let com = ctx.Typecore.com in + (* Use macro context if needed *) + let com = if sign <> (CommonCache.get_cache_sign com) then + (match com.get_macros() with + | None -> + ignore(MacroContext.get_macro_context ctx); + Option.get (com.get_macros()) + | Some com -> com) + else com + in + assert (sign = (CommonCache.get_cache_sign com)); + (* Make sure cache is created *) + ignore(CommonCache.get_cache com); + HxbRestore.find cs sign com path (* 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. *) diff --git a/src/context/common.ml b/src/context/common.ml index 36f3d226336..905a8ff9a73 100644 --- a/src/context/common.ml +++ b/src/context/common.ml @@ -20,6 +20,7 @@ open Extlib_leftovers open Ast open Type open Globals +open Lookup open Define open NativeLibraries open Warning @@ -292,68 +293,6 @@ type report_mode = | RMDiagnostics of Path.UniqueKey.t list | RMStatistics -class virtual ['key,'value] lookup = object(self) - method virtual add : 'key -> 'value -> unit - method virtual remove : 'key -> unit - method virtual find : 'key -> 'value - method virtual iter : ('key -> 'value -> unit) -> unit - method virtual fold : 'acc . ('key -> 'value -> 'acc -> 'acc) -> 'acc -> 'acc - method virtual mem : 'key -> bool - method virtual clear : unit -end - -class ['key,'value] pmap_lookup = object(self) - inherit ['key,'value] lookup - val mutable lut : ('key,'value) PMap.t = PMap.empty - - method add (key : 'key) (value : 'value) = - lut <- PMap.add key value lut - - method remove (key : 'key) = - lut <- PMap.remove key lut - - method find (key : 'key) : 'value = - PMap.find key lut - - method iter (f : 'key -> 'value -> unit) = - PMap.iter f lut - - method fold : 'acc . ('key -> 'value -> 'acc -> 'acc) -> 'acc -> 'acc = fun f acc -> - PMap.foldi f lut acc - - method mem (key : 'key) = - PMap.mem key lut - - method clear = - lut <- PMap.empty -end - -class ['key,'value] hashtbl_lookup = object(self) - inherit ['key,'value] lookup - val lut : ('key,'value) Hashtbl.t = Hashtbl.create 0 - - method add (key : 'key) (value : 'value) = - Hashtbl.replace lut key value - - method remove (key : 'key) = - Hashtbl.remove lut key - - method find (key : 'key) : 'value = - Hashtbl.find lut key - - method iter (f : 'key -> 'value -> unit) = - Hashtbl.iter f lut - - method fold : 'acc . ('key -> 'value -> 'acc -> 'acc) -> 'acc -> 'acc = fun f acc -> - Hashtbl.fold f lut acc - - method mem (key : 'key) = - Hashtbl.mem lut key - - method clear = - Hashtbl.clear lut -end - type context = { compilation_step : int; mutable stage : compiler_stage; diff --git a/src/context/commonCache.ml b/src/context/commonCache.ml index 5156261f02c..ffda15698d4 100644 --- a/src/context/commonCache.ml +++ b/src/context/commonCache.ml @@ -65,7 +65,7 @@ let handle_native_lib com lib = let get_cache com = match com.Common.cache with | None -> let sign = Define.get_signature com.defines in - com.cs#get_context sign + com.cs#get_or_create_context sign | Some cache -> cache diff --git a/src/context/typecore.ml b/src/context/typecore.ml index bee226c08b9..03a4e2a1819 100644 --- a/src/context/typecore.ml +++ b/src/context/typecore.ml @@ -20,6 +20,7 @@ open Globals open Ast open Common +open Lookup open Type open Error open Resolution diff --git a/src/core/define.ml b/src/core/define.ml index 2494cb64ecf..a876758396e 100644 --- a/src/core/define.ml +++ b/src/core/define.ml @@ -121,6 +121,8 @@ let get_signature_raw def = ) def.values [] in String.concat "@" (List.sort compare defines) +let digest_tbl = Hashtbl.create 0 + let get_signature def = match def.defines_signature with | Some s -> s @@ -129,8 +131,12 @@ let get_signature def = (* Printf.eprintf "Defines: %s\n" str; *) let s = Digest.string str in def.defines_signature <- Some s; + Hashtbl.add digest_tbl s str; s +let retrieve_defines sign = + try Hashtbl.find digest_tbl sign with Not_found -> "[cannot find defines for sign %s]" ^ sign + let deprecation_lut = let h = Hashtbl.create 0 in List.iter (fun (name,reason) -> diff --git a/src/typing/finalization.ml b/src/typing/finalization.ml index 6b8141c6856..5cc23fdf873 100644 --- a/src/typing/finalization.ml +++ b/src/typing/finalization.ml @@ -1,5 +1,6 @@ open Globals open Common +open Lookup open Type open Error open TyperBase diff --git a/src/typing/typeloadModule.ml b/src/typing/typeloadModule.ml index b3b404049df..921faaa6d73 100644 --- a/src/typing/typeloadModule.ml +++ b/src/typing/typeloadModule.ml @@ -43,6 +43,14 @@ let field_of_static_definition d p = cff_kind = d.d_data; } +let do_add_module com m = + let sign = CommonCache.get_cache_sign com in + if m.m_extra.m_sign <> sign then begin + trace (Printf.sprintf "Adding module %s with a different sign!" (s_type_path m.m_path)); + trace (Define.retrieve_defines sign); + trace (Define.retrieve_defines m.m_extra.m_sign); + end else com.module_lut#add m.m_path m; + module ModuleLevel = struct let make_module ctx mpath file = let m = { @@ -56,7 +64,8 @@ module ModuleLevel = struct let add_module ctx m p = List.iter (TypeloadCheck.check_module_types ctx m p) m.m_types; - ctx.com.module_lut#add m.m_path m + (* ctx.com.module_lut#add m.m_path m *) + do_add_module ctx.com m (* Build module structure : should be atomic - no type loading is possible @@ -785,7 +794,8 @@ let type_types_into_module ctx m tdecls p = *) let type_module ctx mpath file ?(dont_check_path=false) ?(is_extern=false) tdecls p = let m = ModuleLevel.make_module ctx mpath file in - ctx.com.module_lut#add m.m_path m; + (* ctx.com.module_lut#add m.m_path m; *) + do_add_module ctx.com m; let tdecls = ModuleLevel.handle_import_hx ctx m tdecls p in let ctx = type_types_into_module ctx 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_path p; @@ -809,7 +819,8 @@ let rec get_reader ctx = in let add_module m = - ctx.com.module_lut#add m.m_path m + (* ctx.com.module_lut#add m.m_path m *) + do_add_module ctx.com m; in let flush_fields () = @@ -861,7 +872,8 @@ and load_module' ctx g mpath p = (* Check cache *) match !type_module_hook ctx mpath p with | Some m -> - ctx.com.module_lut#add mpath m; + (* ctx.com.module_lut#add mpath m; *) + do_add_module ctx.com m; m (* Try loading from hxb first, then from source *) | None -> try load_hxb_module ctx mpath p with Not_found -> diff --git a/src/typing/typer.ml b/src/typing/typer.ml index 3425e6199bf..adcf8684c78 100644 --- a/src/typing/typer.ml +++ b/src/typing/typer.ml @@ -22,6 +22,7 @@ open DisplayTypes.DisplayMode open DisplayTypes.CompletionResultKind open CompletionItem.ClassFieldOrigin open Common +open Lookup open Type open Typecore open Resolution