From 931c8c96bf996518ce8498a7ba79c35c9b5e29cb Mon Sep 17 00:00:00 2001 From: Rudy Ges Date: Wed, 8 May 2024 16:06:13 +0200 Subject: [PATCH 1/5] [hxb] make sure display requests don't alter binary cache --- src/compiler/compilationCache.ml | 23 ++++++++++++++++++++--- src/compiler/server.ml | 1 + 2 files changed, 21 insertions(+), 3 deletions(-) diff --git a/src/compiler/compilationCache.ml b/src/compiler/compilationCache.ml index c8563b6a5d0..7552b919d39 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 @@ -86,7 +97,11 @@ class context_cache (index : int) (sign : Digest.t) = object(self) } method clear_cache = - Hashtbl.clear modules + Hashtbl.clear modules; + Hashtbl.clear tmp_binary_cache + + method reset = + Hashtbl.clear tmp_binary_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 reset = + Hashtbl.iter (fun _ ctx -> ctx#reset) contexts + method get_context sign = try Hashtbl.find contexts sign diff --git a/src/compiler/server.ml b/src/compiler/server.ml index 02e00cf770f..301f50a7731 100644 --- a/src/compiler/server.ml +++ b/src/compiler/server.ml @@ -640,6 +640,7 @@ let after_save sctx ctx = maybe_cache_context sctx ctx.com let after_compilation sctx ctx = + sctx.cs#reset; () let mk_length_prefixed_communication allow_nonblock chin chout = From 443739726e14c719e5debdcda38dba2e26fdaa3a Mon Sep 17 00:00:00 2001 From: Rudy Ges Date: Wed, 8 May 2024 16:07:31 +0200 Subject: [PATCH 2/5] [hxb] display requests: consider all hxb modules good unless current display file (#thisisfine) --- src/compiler/server.ml | 27 ++++++++++++++++++--------- 1 file changed, 18 insertions(+), 9 deletions(-) diff --git a/src/compiler/server.ml b/src/compiler/server.ml index 301f50a7731..fe934122e73 100644 --- a/src/compiler/server.ml +++ b/src/compiler/server.ml @@ -448,10 +448,14 @@ class hxb_reader_api_server 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 + 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 @@ -550,15 +554,20 @@ and type_module sctx com delay mpath p = try let m = cc#find_module m_path in begin match m.m_extra.m_cache_state with - | MSBad reason -> BadModule reason + | 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 + 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 in From 29e5b9e1cf3193cfc6f3a773f90d6fdad404410f Mon Sep 17 00:00:00 2001 From: Rudy Ges Date: Thu, 9 May 2024 08:06:36 +0200 Subject: [PATCH 3/5] [server] add module skip reason to 'Unexpected BadModule' error --- src/compiler/server.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/compiler/server.ml b/src/compiler/server.ml index fe934122e73..89de7f4504c 100644 --- a/src/compiler/server.ml +++ b/src/compiler/server.ml @@ -439,7 +439,7 @@ 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__ From 1ddd8663200ea0888407190a0e6425ec815bf6a6 Mon Sep 17 00:00:00 2001 From: Rudy Ges Date: Fri, 10 May 2024 15:17:54 +0200 Subject: [PATCH 4/5] Rename cs#reset to cs#clear_temp_cache --- src/compiler/compilationCache.ml | 12 ++++++------ src/compiler/server.ml | 2 +- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/compiler/compilationCache.ml b/src/compiler/compilationCache.ml index 7552b919d39..896a3a977de 100644 --- a/src/compiler/compilationCache.ml +++ b/src/compiler/compilationCache.ml @@ -96,12 +96,12 @@ class context_cache (index : int) (sign : Digest.t) = object(self) mc_extra = { m.m_extra with m_cache_state = MSGood } } - method clear_cache = - Hashtbl.clear modules; + method clear_temp_cache = Hashtbl.clear tmp_binary_cache - method reset = - Hashtbl.clear tmp_binary_cache + method clear_cache = + Hashtbl.clear modules; + self#clear_temp_cache (* initialization *) @@ -169,8 +169,8 @@ class cache = object(self) (* contexts *) - method reset = - Hashtbl.iter (fun _ ctx -> ctx#reset) contexts + method clear_temp_cache = + Hashtbl.iter (fun _ ctx -> ctx#clear_temp_cache) contexts method get_context sign = try diff --git a/src/compiler/server.ml b/src/compiler/server.ml index 89de7f4504c..3b7e191d761 100644 --- a/src/compiler/server.ml +++ b/src/compiler/server.ml @@ -649,7 +649,7 @@ let after_save sctx ctx = maybe_cache_context sctx ctx.com let after_compilation sctx ctx = - sctx.cs#reset; + sctx.cs#clear_temp_cache; () let mk_length_prefixed_communication allow_nonblock chin chout = From 023f9875536893795c3d51acc96e3cdfe79474fe Mon Sep 17 00:00:00 2001 From: Rudy Ges Date: Fri, 10 May 2024 15:23:22 +0200 Subject: [PATCH 5/5] Factorize code in server.ml --- src/compiler/server.ml | 43 +++++++++++++++++------------------------- 1 file changed, 17 insertions(+), 26 deletions(-) diff --git a/src/compiler/server.ml b/src/compiler/server.ml index 3b7e191d761..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) @@ -446,18 +460,7 @@ class hxb_reader_api_server 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 - 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 + with Not_found -> get_hxb_module com cc m_path method basic_types = com.basic @@ -554,22 +557,10 @@ and type_module sctx com delay mpath p = try let m = cc#find_module m_path in begin match m.m_extra.m_cache_state with - | MSBad reason -> - BadModule reason + | MSBad reason -> BadModule reason | _ -> GoodModule m end; - with Not_found -> try - let mc = cc#get_hxb_module m_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 + 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