[hxb] Ignore invalidations during display requests (#11660)

* [hxb] make sure display requests don't alter binary cache

* [hxb] display requests: consider all hxb modules good unless current display file

(#thisisfine)

* [server] add module skip reason to 'Unexpected BadModule' error

* Rename cs#reset to cs#clear_temp_cache

* Factorize code in server.ml

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

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 =