[hxb] Recover from BadModule failure (#12395)

This currently can happen when current display module (which will be
invalidated in case of completion for example) is an indirect dependency
of a module that ends up being loaded from init macros. Other cases
should usually behave already from what I've seen.

So here, when we're _not_ in full restore mode (display requests only,
with some additional constraints), we're allowing hxb restoration of
"BadModule" modules, avoiding a compiler failure. That "bad" module is
then discarded, avoiding cache corruption (yes, this means it
technically can happen more than once in a request, but that should be
_very_ rare and not that much of an issue since no typing is involved).

src-json/warning.json

@@ -129,6 +129,11 @@
 		"name": "WHxb",
 		"doc": "Hxb (either --hxb output or haxe compiler cache) related warnings"
 	},
+	{
+		"name": "WIgnoredBadModule",
+		"doc": "An invalidated module has been ignored during a display request",
+		"parent": "WHxb"
+	},
 	{
 		"name": "WUnboundTypeParameter",
 		"doc": "Hxb (either --hxb output or haxe compiler cache) failed to link a type parameter to an actual type",

src/compiler/compiler.ml

@@ -306,6 +306,8 @@ let do_type ctx mctx actx display_file_dot_path =
 	Setup.init_native_libs com actx.native_libs;
 	let tctx = Setup.create_typer_context ctx macros in
 	let display_file_dot_path = DisplayProcessing.maybe_load_display_file_before_typing tctx display_file_dot_path in
+	(* Make sure display module is being typed *)
+	Option.may (fun cpath -> actx.classes <- cpath :: actx.classes) display_file_dot_path;
 	DumpConfig.update_from_defines com.dump_config com.defines;
 	CommonCache.lock_signature com "after_init_macros";
 	Option.may (fun mctx -> MacroContext.finalize_macro_api tctx mctx) mctx;

src/compiler/hxb/hxbData.ml

@@ -63,6 +63,10 @@ type module_cache = {
 	mc_extra : module_def_extra;
 }
 
+type typing_mode =
+	| FullTyping
+	| AllowPartialTyping
+
 let string_of_chunk_kind = function
 	| STR -> "STR"
 	| DOC -> "DOC"

src/compiler/hxb/hxbReader.ml

@@ -151,7 +151,7 @@ class hxb_reader
 	(timer_ctx : Timer.timer_context option)
 = object(self)
 	val mutable api = Obj.magic ""
-	val mutable full_restore = true
+	val mutable typing_mode = FullTyping
 	val mutable current_module = null_module
 
 	val mutable ch = BytesWithPosition.create (Bytes.create 0)
@@ -176,15 +176,16 @@ class hxb_reader
 	val empty_anon = mk_anon (ref Closed)
 
 	method resolve_type pack mname tname =
-		try
-			let mt = api#resolve_type pack mname tname in
-			if not full_restore then begin
+		try begin
+			let mt = api#resolve_type pack mname tname typing_mode in
+			(match typing_mode with
+			| AllowPartialTyping ->
 				let mdep = (t_infos mt).mt_module in
 				if mdep != null_module && current_module.m_path != mdep.m_path then
 					current_module.m_extra.m_display_deps <- Some (PMap.add mdep.m_id (create_dependency mdep MDepFromTyping) (Option.get current_module.m_extra.m_display_deps))
-			end;
+			| FullTyping -> ());
 			mt
-		with Not_found ->
+		end with Not_found ->
 			dump_backtrace();
 			error (Printf.sprintf "[HXB] [%s] Cannot resolve type %s" (s_type_path current_module.m_path) (s_type_path ((pack @ [mname]),tname)))
 
@@ -1910,7 +1911,7 @@ class hxb_reader
 		let length = read_uleb128 ch in
 		for _ = 0 to length - 1 do
 			let path = self#read_path in
-			ignore(api#resolve_module path)
+			ignore(api#resolve_module path typing_mode)
 		done
 
 	method read_mtf =
@@ -2017,12 +2018,12 @@ class hxb_reader
 		| MDF ->
 			current_module <- self#read_mdf;
 			incr stats.modules_partially_restored;
-			if not full_restore then current_module.m_extra.m_display_deps <- Some PMap.empty
+			if typing_mode = AllowPartialTyping then current_module.m_extra.m_display_deps <- Some PMap.empty
 		| MTF ->
 			current_module.m_types <- self#read_mtf;
 			api#add_module current_module;
 		| IMP ->
-			if full_restore then self#read_imports;
+			if typing_mode = FullTyping then self#read_imports;
 		| CLR ->
 			self#read_clr;
 		| ENR ->
@@ -2092,11 +2093,11 @@ class hxb_reader
 		close()
 
 	method read_chunks (new_api : hxb_reader_api) (chunks : cached_chunks) =
-		fst (self#read_chunks_until new_api chunks EOM true)
+		fst (self#read_chunks_until new_api chunks EOM FullTyping)
 
-	method read_chunks_until (new_api : hxb_reader_api) (chunks : cached_chunks) end_chunk full_restore' =
+	method read_chunks_until (new_api : hxb_reader_api) (chunks : cached_chunks) end_chunk typing_mode' =
 		api <- new_api;
-		full_restore <- full_restore';
+		typing_mode <- typing_mode';
 		let rec loop = function
 			| (kind,data) :: chunks ->
 				ch <- BytesWithPosition.create data;
@@ -2109,7 +2110,7 @@ class hxb_reader
 
 	method read (new_api : hxb_reader_api) (bytes : bytes) =
 		api <- new_api;
-		full_restore <- true;
+		typing_mode <- FullTyping;
 		ch <- BytesWithPosition.create bytes;
 		if (Bytes.to_string (read_bytes ch 3)) <> "hxb" then
 			raise (HxbFailure "magic");

src/compiler/hxb/hxbReaderApi.ml

@@ -4,8 +4,8 @@ open Type
 class virtual hxb_reader_api = object(self)
 	method virtual make_module : path -> string -> module_def
 	method virtual add_module : module_def -> unit
-	method virtual resolve_type : string list -> string -> string -> module_type
-	method virtual resolve_module : path -> module_def
+	method virtual resolve_type : string list -> string -> string -> HxbData.typing_mode -> module_type
+	method virtual resolve_module : path -> HxbData.typing_mode -> module_def
 	method virtual basic_types : basic_types
 	method virtual get_var_id : int -> int
 	method virtual read_expression_eagerly : tclass_field -> bool
@@ -17,8 +17,8 @@ class hxb_reader_api_null = object(self)
 
 	method make_module _ = assert false
 	method add_module _ = assert false
-	method resolve_type _ _ _ = assert false
-	method resolve_module _ = assert false
+	method resolve_type _ _ _ _ = assert false
+	method resolve_module _ _ = assert false
 	method basic_types = assert false
 	method get_var_id _ = assert false
 	method read_expression_eagerly _ = assert false

src/compiler/server.ml

@@ -223,12 +223,14 @@ let get_changed_directories sctx com =
 let get_changed_directories sctx com =
 	Timer.time com.Common.timer_ctx ["server";"module cache";"changed dirs"] (get_changed_directories sctx) com
 
-let full_typing com m_extra =
-	com.is_macro_context
-	|| com.display.dms_full_typing
-	|| Define.defined com.defines Define.DisableHxbCache
-	|| Define.defined com.defines Define.DisableHxbOptimizations
-	|| DisplayPosition.display_position#is_in_file (Path.UniqueKey.lazy_key m_extra.m_file)
+let get_typing_mode com m_extra =
+	let full_typing = com.is_macro_context
+		|| com.display.dms_full_typing
+		|| Define.defined com.defines Define.DisableHxbCache
+		|| Define.defined com.defines Define.DisableHxbOptimizations
+		|| DisplayPosition.display_position#is_in_file (Path.UniqueKey.lazy_key m_extra.m_file)
+	in
+	if full_typing then FullTyping else AllowPartialTyping
 
 (* 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. *)
@@ -331,7 +333,7 @@ let check_module sctx com m_path m_extra p =
 			try
 				check_module_path();
 				if not (has_policy NoFileSystemCheck) || Path.file_extension (Path.UniqueKey.lazy_path m_extra.m_file) <> "hx" then check_file();
-				if full_typing com m_extra then check_dependencies();
+				if (get_typing_mode com m_extra) = FullTyping then check_dependencies();
 				None
 			with
 			| Dirty reason ->
@@ -390,17 +392,19 @@ let check_module sctx com m_path m_extra p =
 	end;
 	state
 
-let get_hxb_module com cc path =
+let get_hxb_module com cc path typing_mode =
 	try
 		let mc = cc#get_hxb_module path in
-		if not (full_typing com mc.mc_extra) 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
+		match get_typing_mode com mc.mc_extra with
+			| AllowPartialTyping ->
+				mc.mc_extra.m_cache_state <- MSGood;
+				BinaryModule mc
+			| FullTyping ->
+				begin match mc.mc_extra.m_cache_state with
+					| MSBad reason when typing_mode = AllowPartialTyping -> BadBinaryModule (mc, reason)
+					| MSBad reason -> BadModule reason
+					| _ -> BinaryModule mc
+				end
 	with Not_found ->
 		NoModule
 
@@ -425,18 +429,36 @@ class hxb_reader_api_server
 	method add_module (m : module_def) =
 		com.module_lut#add m.m_path m
 
-	method resolve_type (pack : string list) (mname : string) (tname : string) =
+	method resolve_type (pack : string list) (mname : string) (tname : string) full_restore =
 		let path = (pack,mname) in
-		let m = self#resolve_module path in
+		let m = self#resolve_module path full_restore in
 		List.find (fun t -> snd (t_path t) = tname) m.m_types
 
-	method resolve_module (path : path) =
-		match self#find_module path with
+	method resolve_module (path : path) full_restore =
+		match self#find_module path full_restore with
 		| GoodModule m ->
 			m
 		| BinaryModule mc ->
 			let reader = new HxbReader.hxb_reader path com.hxb_reader_stats (if Common.defined com Define.HxbTimes then Some com.timer_ctx else None) in
-			let full_restore = full_typing com mc.mc_extra in
+			let typing_mode = get_typing_mode com mc.mc_extra in
+			let f_next chunks until =
+				let macro = if com.is_macro_context then " (macro)" else "" in
+				let f  = reader#read_chunks_until (self :> HxbReaderApi.hxb_reader_api) chunks until in
+				Timer.time com.timer_ctx ["server";"module cache";"hxb read" ^ macro;"until " ^ (string_of_chunk_kind until)] f typing_mode
+			in
+
+			let m,chunks = f_next mc.mc_chunks EOT in
+
+			(* We try to avoid reading expressions as much as possible, so we only do this for
+				 our current display file if we're in display mode. *)
+			(match typing_mode with
+			| FullTyping -> ignore(f_next chunks EOM)
+			| AllowPartialTyping -> delay PConnectField (fun () -> ignore(f_next chunks EOF)));
+			incr stats.s_modules_restored;
+			m
+		| BadBinaryModule (mc, reason) ->
+			let reader = new HxbReader.hxb_reader path com.hxb_reader_stats (if Common.defined com Define.HxbTimes then Some com.timer_ctx else None) in
+			let typing_mode = get_typing_mode com mc.mc_extra in
 			let f_next chunks until =
 				let macro = if com.is_macro_context then " (macro)" else "" in
 				let f  = reader#read_chunks_until (self :> HxbReaderApi.hxb_reader_api) chunks until in
@@ -444,11 +466,13 @@ class hxb_reader_api_server
 			in
 
 			let m,chunks = f_next mc.mc_chunks EOT in
+			m.m_extra.m_cache_state <- MSBad reason;
 
 			(* We try to avoid reading expressions as much as possible, so we only do this for
 				 our current display file if we're in display mode. *)
-			if full_restore then ignore(f_next chunks EOM)
-			else delay PConnectField (fun () -> ignore(f_next chunks EOF));
+			(match typing_mode with
+			| FullTyping -> ignore(f_next chunks EOM)
+			| AllowPartialTyping -> delay PConnectField (fun () -> ignore(f_next chunks EOF)));
 			incr stats.s_modules_restored;
 			m
 		| BadModule reason ->
@@ -456,10 +480,10 @@ class hxb_reader_api_server
 		| NoModule ->
 			die (Printf.sprintf "Unexpected NoModule %s" (s_type_path path)) __LOC__
 
-	method find_module (m_path : path) =
+	method find_module (m_path : path) typing_mode =
 		try
 			GoodModule (com.module_lut#find m_path)
-		with Not_found -> get_hxb_module com cc m_path
+		with Not_found -> get_hxb_module com cc m_path typing_mode
 
 	method basic_types =
 		com.basic
@@ -491,7 +515,16 @@ let handle_cache_bound_objects com cbol =
 let rec add_modules sctx com delay (m : module_def) (from_binary : bool) (p : pos) =
 	let own_sign = CommonCache.get_cache_sign com in
 	let rec add_modules tabs m0 m =
-		if m.m_extra.m_added < com.compilation_step then begin
+		if m.m_extra.m_cache_state <> MSGood then begin
+			(match m.m_extra.m_cache_state with
+				| MSBad reason when com.display.dms_full_typing ->
+					failwith (Printf.sprintf "Unexpected bad module %s (%s)" (s_type_path m.m_path) (Printer.s_module_skip_reason reason))
+				| MSBad reason ->
+					com.warning WIgnoredBadModule com.warning_options (Printf.sprintf "Ignored bad module %s (%s)" (s_type_path m.m_path) (Printer.s_module_skip_reason reason)) p
+				| _ -> ()
+			);
+			com.module_lut#remove m.m_path
+		end else if m.m_extra.m_added < com.compilation_step then begin
 			m.m_extra.m_added <- com.compilation_step;
 			(match m0.m_extra.m_kind, m.m_extra.m_kind with
 			| MCode, MMacro | MMacro, MCode ->
@@ -507,26 +540,31 @@ let rec add_modules sctx com delay (m : module_def) (from_binary : bool) (p : po
 				if not from_binary || m != m then
 					com.module_lut#add m.m_path m;
 				handle_cache_bound_objects com m.m_extra.m_cache_bound_objects;
-				let full_restore = full_typing com m.m_extra in
+				let typing_mode = get_typing_mode com m.m_extra in
 				PMap.iter (fun _ mdep ->
 					let mpath = mdep.md_path in
 					if mdep.md_sign = own_sign then begin
 						let m2 = try
-							com.module_lut#find mpath
+							Some (com.module_lut#find mpath)
 						with Not_found ->
 							match type_module sctx com delay mpath p with
 							| GoodModule m ->
-								m
+								Some m
 							| BinaryModule mc ->
 								failwith (Printf.sprintf "Unexpectedly found unresolved binary module %s as a dependency of %s" (s_type_path mpath) (s_type_path m0.m_path))
 							| NoModule ->
 								failwith (Printf.sprintf "Unexpectedly could not find module %s as a dependency of %s" (s_type_path mpath) (s_type_path m0.m_path))
+							| BadBinaryModule (_, reason) | BadModule reason when typing_mode = AllowPartialTyping ->
+								com.warning WIgnoredBadModule com.warning_options (Printf.sprintf "Ignored bad dependency %s (%s) of %s" (s_type_path m.m_path) (Printer.s_module_skip_reason reason) (s_type_path m0.m_path)) p;
+								None
+							| BadBinaryModule (_, reason) ->
+								failwith (Printf.sprintf "Unexpected bad hxb module %s (%s) as a dependency of %s" (s_type_path mpath) (Printer.s_module_skip_reason reason) (s_type_path m0.m_path))
 							| BadModule reason ->
 								failwith (Printf.sprintf "Unexpected bad module %s (%s) as a dependency of %s" (s_type_path mpath) (Printer.s_module_skip_reason reason) (s_type_path m0.m_path))
 						in
-						add_modules (tabs ^ "  ") m0 m2
+						Option.may (fun m2 -> add_modules (tabs ^ "  ") m0 m2) m2
 					end
-				) (if full_restore then m.m_extra.m_deps else Option.default m.m_extra.m_deps m.m_extra.m_display_deps)
+				) (if typing_mode = FullTyping then m.m_extra.m_deps else Option.default m.m_extra.m_deps m.m_extra.m_display_deps)
 			)
 		end
 	in
@@ -555,7 +593,7 @@ and type_module sctx com delay mpath p =
 				| MSBad reason -> BadModule reason
 				| _ -> GoodModule m
 			end;
-		with Not_found -> get_hxb_module com cc m_path
+		with Not_found -> get_hxb_module com cc m_path FullTyping
 	in
 	(* Should not raise anything! *)
 	let m = match find_module_in_cache cc mpath p with
@@ -574,7 +612,7 @@ and type_module sctx com delay mpath p =
 			begin match check_module sctx mpath mc.mc_extra p with
 				| None ->
 					let reader = new HxbReader.hxb_reader mpath com.hxb_reader_stats (if Common.defined com Define.HxbTimes then Some com.timer_ctx else None) in
-					let full_restore = full_typing com mc.mc_extra in
+					let typing_mode = get_typing_mode com mc.mc_extra in
 					let api = match com.hxb_reader_api with
 						| Some api ->
 							api
@@ -585,20 +623,24 @@ and type_module sctx com delay mpath p =
 					in
 					let f_next chunks until =
 						let macro = if com.is_macro_context then " (macro)" else "" in
-						Timer.time com.timer_ctx ["server";"module cache";"hxb read" ^ macro;"until " ^ (string_of_chunk_kind until)] (reader#read_chunks_until api chunks until) full_restore
+						Timer.time com.timer_ctx ["server";"module cache";"hxb read" ^ macro;"until " ^ (string_of_chunk_kind until)] (reader#read_chunks_until api chunks until) typing_mode
 					in
 
 					let m,chunks = f_next mc.mc_chunks EOT in
 
 					(* We try to avoid reading expressions as much as possible, so we only do this for
 					   our current display file if we're in display mode. *)
-					if full_restore then ignore(f_next chunks EOM)
-					else delay PConnectField (fun () -> ignore(f_next chunks EOF));
+					(match typing_mode with
+					| FullTyping -> ignore(f_next chunks EOM)
+					| AllowPartialTyping -> delay PConnectField (fun () -> ignore(f_next chunks EOF)));
 					incr stats.s_modules_restored;
 					add_modules true m;
 				| Some reason ->
 					skip mpath reason
 			end
+		| BadBinaryModule (_, reason) ->
+			(* A BadModule state here means that the module is already invalidated in the cache, e.g. from server/invalidate. *)
+			skip mpath reason
 		| BadModule reason ->
 			(* A BadModule state here means that the module is already invalidated in the cache, e.g. from server/invalidate. *)
 			skip mpath reason

src/context/display/displayJson.ml

@@ -104,7 +104,7 @@ class display_handler (jsonrpc : jsonrpc_handler) com (cs : CompilationCache.t)
 end
 
 class hxb_reader_api_com
-	~(full_restore : bool)
+	~(typing_mode : HxbData.typing_mode)
 	(com : Common.context)
 	(cc : CompilationCache.context_cache)
 = object(self)
@@ -123,12 +123,12 @@ class hxb_reader_api_com
 	method add_module (m : module_def) =
 		com.module_lut#add m.m_path m;
 
-	method resolve_type (pack : string list) (mname : string) (tname : string) =
+	method resolve_type (pack : string list) (mname : string) (tname : string) (_:HxbData.typing_mode) =
 		let path = (pack,mname) in
 		let m = self#find_module path in
 		List.find (fun t -> snd (t_path t) = tname) m.m_types
 
-	method resolve_module (path : path) =
+	method resolve_module (path : path) (_:HxbData.typing_mode) =
 		self#find_module path
 
 	method find_module (m_path : path) =
@@ -139,7 +139,7 @@ class hxb_reader_api_com
 		with Not_found ->
 			let mc = cc#get_hxb_module m_path in
 			let reader = new HxbReader.hxb_reader mc.mc_path com.hxb_reader_stats (if Common.defined com Define.HxbTimes then Some com.timer_ctx else None) in
-			fst (reader#read_chunks_until (self :> HxbReaderApi.hxb_reader_api) mc.mc_chunks (if full_restore then EOM else MTF) full_restore)
+			fst (reader#read_chunks_until (self :> HxbReaderApi.hxb_reader_api) mc.mc_chunks (if typing_mode = FullTyping then EOM else MTF) typing_mode)
 
 	method basic_types =
 		com.basic
@@ -154,8 +154,8 @@ class hxb_reader_api_com
 		TLazy (make_unforced_lazy t f "com-api")
 end
 
-let find_module ~(full_restore : bool) com cc path =
-	(new hxb_reader_api_com ~full_restore com cc)#find_module path
+let find_module ~(typing_mode : HxbData.typing_mode) com cc path =
+	(new hxb_reader_api_com ~typing_mode com cc)#find_module path
 
 type handler_context = {
 	com : Common.context;
@@ -350,13 +350,13 @@ let handler =
 			let path = Path.parse_path (hctx.jsonrpc#get_string_param "path") in
 			let cs = hctx.display#get_cs in
 			let cc = cs#get_context sign in
-			let full_restore = Define.defined hctx.com.defines Define.DisableHxbOptimizations in
+			let typing_mode:HxbData.typing_mode = if Define.defined hctx.com.defines Define.DisableHxbOptimizations then FullTyping else AllowPartialTyping in
 			let m = try
-				find_module ~full_restore hctx.com cc path
+				find_module ~typing_mode hctx.com cc path
 			with Not_found ->
 				hctx.send_error [jstring "No such module"]
 			in
-			hctx.send_result (generate_module (cc#get_hxb) (find_module ~full_restore hctx.com cc) m)
+			hctx.send_result (generate_module (cc#get_hxb) (find_module ~typing_mode hctx.com cc) m)
 		);
 		"server/type", (fun hctx ->
 			let sign = Digest.from_hex (hctx.jsonrpc#get_string_param "signature") in
@@ -364,7 +364,7 @@ let handler =
 			let typeName = hctx.jsonrpc#get_string_param "typeName" in
 			let cc = hctx.display#get_cs#get_context sign in
 			let m = try
-				find_module ~full_restore:true hctx.com cc path
+				find_module ~typing_mode:FullTyping hctx.com cc path
 			with Not_found ->
 				hctx.send_error [jstring "No such module"]
 			in

src/context/display/displayTexpr.ml

@@ -175,7 +175,7 @@ let check_display_file ctx cs =
 				ctx.com.module_lut#find path
 			with Not_found ->
 				begin match !TypeloadCacheHook.type_module_hook ctx.com (delay ctx.g) path null_pos with
-				| NoModule | BadModule _ -> raise Not_found
+				| NoModule | BadModule _ | BadBinaryModule _ -> raise Not_found
 				| BinaryModule mc ->
 					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 (if Common.defined ctx.com Define.HxbTimes then Some ctx.com.timer_ctx else None) in

src/typing/typeloadCacheHook.ml

@@ -7,6 +7,7 @@ open TFunctions
 type find_module_result =
 	| GoodModule of module_def
 	| BadModule of module_skip_reason
+	| BadBinaryModule of (HxbData.module_cache * module_skip_reason)
 	| BinaryModule of HxbData.module_cache
 	| NoModule
 

src/typing/typeloadModule.ml

@@ -749,11 +749,11 @@ class hxb_reader_api_typeload
 	method add_module (m : module_def) =
 		com.module_lut#add m.m_path m
 
-	method resolve_type (pack : string list) (mname : string) (tname : string) =
+	method resolve_type (pack : string list) (mname : string) (tname : string) (_:HxbData.typing_mode) =
 		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) =
+	method resolve_module (path : path) (_:HxbData.typing_mode) =
 		load_module com g path p
 
 	method basic_types =
@@ -819,7 +819,7 @@ and load_module' com g m p =
 			m
 		| BinaryModule _ ->
 			die "" __LOC__ (* The server builds those *)
-		| NoModule | BadModule _ -> try
+		| NoModule | BadModule _ | BadBinaryModule _ -> try
 			load_hxb_module com g m p
 		with Not_found ->
 			let raise_not_found () = raise_error_msg (Module_not_found m) p in