diff --git a/src/compiler/compilationCache.ml b/src/compiler/compilationCache.ml index c8563b6a5d0..896a3a977de 100644 --- a/src/compiler/compilationCache.ml +++ b/src/compiler/compilationCache.ml @@ -35,6 +35,7 @@ class context_cache (index : int) (sign : Digest.t) = object(self) val files : (Path.UniqueKey.t,cached_file) Hashtbl.t = Hashtbl.create 0 val modules : (path,module_def) Hashtbl.t = Hashtbl.create 0 val binary_cache : (path,HxbData.module_cache) Hashtbl.t = Hashtbl.create 0 + val tmp_binary_cache : (path,HxbData.module_cache) Hashtbl.t = Hashtbl.create 0 val string_pool = StringPool.create () val removed_files = Hashtbl.create 0 val mutable json = JNull @@ -67,8 +68,18 @@ class context_cache (index : int) (sign : Digest.t) = object(self) method find_module_opt path = Hashtbl.find_opt modules path + method get_hxb_module path = + try Hashtbl.find tmp_binary_cache path + with Not_found -> + let mc = Hashtbl.find binary_cache path in + let m_extra = { mc.mc_extra with m_deps = mc.mc_extra.m_deps } in + let mc = { mc with mc_extra = m_extra } in + Hashtbl.add tmp_binary_cache path mc; + mc + method find_module_extra path = - try (Hashtbl.find modules path).m_extra with Not_found -> (Hashtbl.find binary_cache path).mc_extra + try (Hashtbl.find modules path).m_extra + with Not_found -> (self#get_hxb_module path).mc_extra method cache_module config warn anon_identification path m = match m.m_extra.m_kind with @@ -85,8 +96,12 @@ class context_cache (index : int) (sign : Digest.t) = object(self) mc_extra = { m.m_extra with m_cache_state = MSGood } } + method clear_temp_cache = + Hashtbl.clear tmp_binary_cache + method clear_cache = - Hashtbl.clear modules + Hashtbl.clear modules; + self#clear_temp_cache (* initialization *) @@ -101,7 +116,6 @@ class context_cache (index : int) (sign : Digest.t) = object(self) method get_hxb = binary_cache method get_string_pool = string_pool method get_string_pool_arr = string_pool.items.arr - method get_hxb_module path = Hashtbl.find binary_cache path (* TODO handle hxb cache there too *) method get_removed_files = removed_files @@ -155,6 +169,9 @@ class cache = object(self) (* contexts *) + method clear_temp_cache = + Hashtbl.iter (fun _ ctx -> ctx#clear_temp_cache) contexts + method get_context sign = try Hashtbl.find contexts sign diff --git a/src/compiler/server.ml b/src/compiler/server.ml index 02e00cf770f..80b9d848253 100644 --- a/src/compiler/server.ml +++ b/src/compiler/server.ml @@ -391,6 +391,20 @@ let check_module sctx com m_path m_extra p = end; state +let get_hxb_module com cc path = + try + let mc = cc#get_hxb_module path in + if not com.is_macro_context && not com.display.dms_full_typing && not (DisplayPosition.display_position#is_in_file (Path.UniqueKey.lazy_key mc.mc_extra.m_file)) then begin + mc.mc_extra.m_cache_state <- MSGood; + BinaryModule mc + end else + begin match mc.mc_extra.m_cache_state with + | MSBad reason -> BadModule reason + | _ -> BinaryModule mc + end + with Not_found -> + NoModule + class hxb_reader_api_server (com : Common.context) (cc : context_cache) @@ -439,21 +453,14 @@ class hxb_reader_api_server else delay (fun () -> ignore(f_next chunks EOF)); m | BadModule reason -> - die (Printf.sprintf "Unexpected BadModule %s" (s_type_path path)) __LOC__ + die (Printf.sprintf "Unexpected BadModule %s (%s)" (s_type_path path) (Printer.s_module_skip_reason reason)) __LOC__ | NoModule -> die (Printf.sprintf "Unexpected NoModule %s" (s_type_path path)) __LOC__ method find_module (m_path : path) = try 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 - | MSBad reason -> BadModule reason - | _ -> BinaryModule mc - end - with Not_found -> - NoModule + with Not_found -> get_hxb_module com cc m_path method basic_types = com.basic @@ -553,14 +560,7 @@ and type_module sctx com delay mpath p = | MSBad reason -> BadModule reason | _ -> GoodModule m end; - with Not_found -> try - let mc = cc#get_hxb_module m_path in - begin match mc.mc_extra.m_cache_state with - | MSBad reason -> BadModule reason - | _ -> BinaryModule mc - end - with Not_found -> - NoModule + with Not_found -> get_hxb_module com cc m_path in (* Should not raise anything! *) let m = match find_module_in_cache cc mpath p with @@ -640,6 +640,7 @@ let after_save sctx ctx = maybe_cache_context sctx ctx.com let after_compilation sctx ctx = + sctx.cs#clear_temp_cache; () let mk_length_prefixed_communication allow_nonblock chin chout =