[hxb] improve handling of tainted dependencies

src/compiler/hxb/hxbReader.ml

@@ -46,6 +46,7 @@ class hxb_reader
 
 	method resolve_type pack mname tname =
 		try resolve_type pack mname tname with
+		| Bad_module (path, reason) -> raise (Bad_module (m.m_path, DependencyDirty (path, reason)))
 		| Not_found -> error (Printf.sprintf "Cannot resolve type %s" (s_type_path ((pack @ [mname]),tname)))
 
 	val mutable tvoid = None

src/compiler/hxb/hxbRestore.ml

@@ -7,28 +7,64 @@ class hxb_restore
 = object(self)
 
 	method find (path : path) =
-		try com.module_lut#find path with
+		(* ServerMessage.debug_msg (Printf.sprintf "[1] Find %s from hxb" (s_type_path path)); *)
+		try begin
+			let m = com.module_lut#find path in
+			(match m.m_extra.m_cache_state with
+				| MSBad reason -> raise (Bad_module (path, reason))
+				| _ -> m
+			)
+		end with
 		| Not_found ->
+			(* ServerMessage.debug_msg (Printf.sprintf "[2] Find %s from hxb" (s_type_path path)); *)
 			match cc#find_module_opt path with
 			| Some m -> m
 			| None ->
-					begin match cc#get_hxb_module path with
-						| None -> raise Not_found
-						| Some mc -> self#load mc
-					end
+				(* ServerMessage.debug_msg (Printf.sprintf "[3] Find %s from hxb" (s_type_path path)); *)
+				begin match cc#get_hxb_module path with
+					| None -> raise Not_found
+					| Some { mc_extra = { m_cache_state = MSBad reason }} -> raise (Bad_module (path, reason))
+					| Some mc -> self#load mc
+				end
 
 	method load (mc : module_cache) =
-		(* print_endline (Printf.sprintf "[1] Load %s from hxb" (s_type_path mc.mc_path)); *)
+		(* ServerMessage.debug_msg (Printf.sprintf "[1] Load %s from hxb" (s_type_path mc.mc_path)); *)
 		let reader = new HxbReader.hxb_reader (self#make_module mc) self#add_module self#resolve_type (fun () -> ()) in
-		reader#read (IO.input_bytes mc.mc_bytes) true null_pos
+		try
+			let m = reader#read (IO.input_bytes mc.mc_bytes) true null_pos in
+			(* ServerMessage.debug_msg (Printf.sprintf "[2] Loaded %s from hxb" (s_type_path mc.mc_path)); *)
+			m
+		with
+		| Bad_module (path, reason) ->
+			ServerMessage.skipping_dep com "" (path,(Printer.s_module_skip_reason reason));
+			com.module_lut#remove mc.mc_path;
+			(* com.module_lut#remove path; *)
+			raise (Bad_module (mc.mc_path, DependencyDirty (path, reason)))
+		| e ->
+			ServerMessage.debug_msg (Printf.sprintf "[1] Error loading %s from hxb" (s_type_path mc.mc_path));
+			com.module_lut#remove mc.mc_path;
+			raise e
 
 	method add_module (m : module_def) =
+		if com.module_lut#mem m.m_path then
+			ServerMessage.debug_msg (Printf.sprintf "Hxb restore adding already existing module %s" (s_type_path m.m_path));
+
+		ServerMessage.reusing com "" m;
 		com.module_lut#add m.m_path m
 
 	method resolve_type (pack : string list) (mname : string) (tname : string) =
 		let path = (pack,mname) in
-		let m = self#find path in
-		List.find (fun t -> snd (t_path t) = tname) m.m_types
+		(* ServerMessage.debug_msg (Printf.sprintf "  resolve type %s (%b)" (s_type_path path) (com.module_lut#mem path)); *)
+		try
+			let m = self#find path in
+			List.find (fun t -> snd (t_path t) = tname) m.m_types
+		with
+		| Bad_module (_, reason) ->
+			ServerMessage.debug_msg (Printf.sprintf "  error resolving type %s (bad)" (s_type_path path));
+			raise (Bad_module (path, reason))
+		| Not_found ->
+			ServerMessage.debug_msg (Printf.sprintf "  error resolving type %s (not found)" (s_type_path path));
+			raise Not_found
 
 	method make_module (mc : module_cache) (path : path) (file : string) =
 		{
@@ -37,7 +73,7 @@ class hxb_restore
 			m_types = [];
 			m_statics = None;
 			m_extra = { mc.mc_extra with
-				m_added = 1;
+				m_added = com.compilation_step;
 				m_checked = 0;
 				m_processed = 1;
 				m_time = (Common.file_time file)

src/compiler/server.ml

@@ -312,7 +312,7 @@ let check_module sctx ctx m p =
 		in
 		let check_dependencies () =
 			PMap.iter (fun _ (sign,mpath) ->
-				let m2 = find_or_restore_module (com.cs#get_context sign) ctx mpath in
+				let m2 = try find_or_restore_module (com.cs#get_context sign) ctx mpath with Bad_module (_, reason) -> raise (Dirty (DependencyDirty(mpath,reason))) in
 				match check m2 with
 				| None -> ()
 				| Some reason -> raise (Dirty (DependencyDirty(m2.m_path,reason)))
@@ -435,9 +435,8 @@ let type_module sctx (ctx:Typecore.typer) mpath p =
 		begin match check_module sctx ctx m p with
 		| None -> ()
 		| Some reason ->
-			ServerMessage.skipping_dep com "" (m,(Printer.s_module_skip_reason reason));
 			tcheck();
-			raise Not_found;
+			raise (Bad_module (m.m_path, reason))
 		end;
 		tcheck();
 		let tadd = Timer.timer ["server";"module cache";"add modules"] in
@@ -445,7 +444,12 @@ let type_module sctx (ctx:Typecore.typer) mpath p =
 		tadd();
 		t();
 		Some m
-	with Not_found ->
+	with
+	| Bad_module (path, reason) ->
+		ServerMessage.skipping_dep com "" (path,(Printer.s_module_skip_reason reason));
+		t();
+		None
+	| Not_found ->
 		t();
 		None
 

src/compiler/serverMessage.ml

@@ -110,8 +110,8 @@ let retyper_fail com tabs m reason =
 		print_endline (Printf.sprintf "%s%s%s" (sign_string com) (tabs ^ "  ") reason);
 	end
 
-let skipping_dep com tabs (m,reason) =
-	if config.print_skipping_dep then print_endline (Printf.sprintf "%sskipping %s (%s)" (sign_string com) (s_type_path m.m_path) reason)
+let skipping_dep com tabs (mpath,reason) =
+	if config.print_skipping_dep then print_endline (Printf.sprintf "%sskipping %s (%s)" (sign_string com) (s_type_path mpath) reason)
 
 let unchanged_content com tabs file =
 	if config.print_unchanged_content then print_endline (Printf.sprintf "%s%s changed time not but content, reusing" (sign_string com) file)

src/core/tType.ml

@@ -39,6 +39,8 @@ type module_skip_reason =
 	| Shadowed of string
 	| LibraryChanged
 
+exception Bad_module of path * module_skip_reason
+
 type module_cache_state =
 	| MSGood
 	| MSBad of module_skip_reason