[hxb] WIP MSRestored cache state

src/compiler/hxb/hxbRestore.ml

@@ -4,18 +4,20 @@ open Type
 class hxb_restore
 	(cs : CompilationCache.t)
 	(com : Common.context)
+	(local_module_lut : ((string * path),module_def) Lookup.hashtbl_lookup)
 = object(self)
 
 	method find (path : path) (sign : string) =
-		try begin
+		try
+			local_module_lut#find (sign, path)
+		with Not_found -> try
 			let m = com.module_lut#find path in
 			if m.m_extra.m_sign <> sign then raise Not_found;
 			(match m.m_extra.m_cache_state with
 				| MSBad reason -> raise (Bad_module (path, reason))
 				| _ -> m
 			)
-		end with
-		| Not_found ->
+		with Not_found ->
 			let cc = cs#get_context sign in
 			match cc#find_module_opt path with
 			| Some m -> m
@@ -31,24 +33,22 @@ class hxb_restore
 		try reader#read (IO.input_bytes mc.mc_bytes) true null_pos 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; *)
+			local_module_lut#remove (mc.mc_extra.m_sign, mc.mc_path);
+			(* local_module_lut#remove path; *)
 			raise (Bad_module (mc.mc_path, DependencyDirty (path, reason)))
 		| HxbData.HxbFailure e ->
 			ServerMessage.debug_msg (Printf.sprintf "Error loading %s from hxb: %s" (s_type_path mc.mc_path) e);
-			com.module_lut#remove mc.mc_path;
+			(* trace (Printf.sprintf "Error loading %s from hxb: %s" (s_type_path mc.mc_path) e); *)
+			local_module_lut#remove (mc.mc_extra.m_sign, mc.mc_path);
 			raise (HxbData.HxbFailure e)
 		| e ->
 			ServerMessage.debug_msg (Printf.sprintf "Error loading %s from hxb" (s_type_path mc.mc_path));
-			com.module_lut#remove mc.mc_path;
+			(* trace (Printf.sprintf "Error loading %s from hxb" (s_type_path mc.mc_path)); *)
+			local_module_lut#remove (mc.mc_extra.m_sign, 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
+		local_module_lut#add (m.m_extra.m_sign, m.m_path) m
 
 	method resolve_type (sign : string) (pack : string list) (mname : string) (tname : string) =
 		let path = (pack,mname) in
@@ -71,17 +71,31 @@ class hxb_restore
 				m_processed = 1;
 				m_features = Hashtbl.create 0; (* ? *)
 				m_if_feature = [];
-				m_time = (Common.file_time file) (* TODO check that... *)
+				m_cache_state = MSRestored mc.mc_extra.m_cache_state;
 			}
 		}
 
 end
 
-let find (cs : CompilationCache.t) (sign : string) (com : Common.context) (path : path) =
-	let loader = new hxb_restore cs com in
+let find
+	(local_module_lut : ((string * path),module_def) Lookup.hashtbl_lookup)
+	(cs : CompilationCache.t)
+	(sign : string)
+	(com : Common.context)
+	(path : path)
+	=
+	(* trace (Printf.sprintf "Find module %s" (s_type_path path)); *)
+	let loader = new hxb_restore cs com local_module_lut in
 	loader#find path sign
 
-let find_type (cs : CompilationCache.t) (sign : string) (com : Common.context) (path : path) =
-	let m = find cs sign com path in
+let find_type
+	(local_module_lut : ((string * path),module_def) Lookup.hashtbl_lookup)
+	(cs : CompilationCache.t)
+	(sign : string)
+	(com : Common.context)
+	(path : path)
+	=
+	(* trace (Printf.sprintf "Find type %s" (s_type_path path)); *)
+	let m = find local_module_lut cs sign com path in
 	List.find (fun t -> snd (t_path t) = (snd path)) m.m_types
 

src/compiler/server.ml

@@ -220,7 +220,7 @@ let get_changed_directories sctx (ctx : Typecore.typer) =
 	t();
 	dirs
 
-let find_or_restore_module cs sign ctx path =
+let find_or_restore_module local_module_lut cs sign ctx path =
 	let com = ctx.Typecore.com in
 	(* Use macro context if needed *)
 	let com = if sign <> (CommonCache.get_cache_sign com) then
@@ -234,11 +234,11 @@ let find_or_restore_module cs sign ctx path =
 	assert (sign = (CommonCache.get_cache_sign com));
 	(* Make sure cache is created *)
 	ignore(CommonCache.get_cache com);
-	HxbRestore.find cs sign com path
+	HxbRestore.find local_module_lut cs sign com path
 
 (* 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. *)
-let check_module sctx ctx m p =
+let check_module local_module_lut sctx ctx m p =
 	let com = ctx.Typecore.com in
 	let cc = CommonCache.get_cache com in
 	let content_changed m file =
@@ -314,7 +314,7 @@ let check_module sctx ctx m p =
 		let check_file () =
 			let file = Path.UniqueKey.lazy_path m.m_extra.m_file in
 			if file_time file <> m.m_extra.m_time then begin
-				if has_policy CheckFileContentModification && not (content_changed m file) then begin
+				if (has_policy CheckFileContentModification || m.m_extra.m_cache_state = MSRestored MSGood) && not (content_changed m file) then begin
 					ServerMessage.unchanged_content com "" file;
 				end else begin
 					ServerMessage.not_cached com "" m;
@@ -325,7 +325,7 @@ let check_module sctx ctx m p =
 		in
 		let check_dependencies () =
 			PMap.iter (fun _ (sign,mpath) ->
-				let m2 = try find_or_restore_module com.cs sign ctx mpath with Bad_module (_, reason) -> raise (Dirty (DependencyDirty(mpath,reason))) in
+				let m2 = try find_or_restore_module local_module_lut com.cs 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)))
@@ -345,6 +345,10 @@ let check_module sctx ctx m p =
 		if m.m_extra.m_checked = start_mark then begin match m.m_extra.m_cache_state with
 			| MSGood | MSUnknown ->
 				None
+			| MSRestored (MSBad reason) ->
+				Some reason
+			| MSRestored _ ->
+				None
 			| MSBad reason ->
 				Some reason
 		end else begin
@@ -357,6 +361,12 @@ let check_module sctx ctx m p =
 				| MSUnknown	->
 					(* This should not happen because any MSUnknown module is supposed to have the current m_checked. *)
 					die "" __LOC__
+				| MSRestored (MSBad reason) ->
+					Some reason
+				| MSRestored _ ->
+					(* TODO check wanted behavior here *)
+					m.m_extra.m_cache_state <- MSUnknown;
+					check ()
 				| MSGood ->
 					(* Otherwise, run the checks *)
 					m.m_extra.m_cache_state <- MSUnknown;
@@ -402,6 +412,14 @@ let check_module sctx ctx m p =
 			| MSUnknown ->
 				m.m_extra.m_checked <- start_mark - 1;
 				m.m_extra.m_cache_state <- MSGood;
+			| MSRestored _ ->
+				(* TODO: is it possible to get there? if so, what to do? *)
+				(* m.m_extra.m_checked <- start_mark - 1; *)
+				(* m.m_extra.m_cache_state <- MSGood; *)
+				trace (s_type_path m.m_path);
+				trace (Printer.s_module_cache_state m.m_extra.m_cache_state);
+				assert false
+				(* () *)
 			| MSGood | MSBad _ ->
 				()
 		) !unknown_state_modules
@@ -410,8 +428,9 @@ let check_module sctx ctx m p =
 
 (* Adds module [m] and all its dependencies (recursively) from the cache to the current compilation
    context. *)
-let add_modules sctx ctx m p =
+let add_modules local_module_lut sctx ctx m p =
 	let com = ctx.Typecore.com in
+
 	let rec add_modules tabs m0 m =
 		if m.m_extra.m_added < ctx.com.compilation_step then begin
 			(match m0.m_extra.m_kind, m.m_extra.m_kind with
@@ -427,24 +446,32 @@ let add_modules sctx ctx m p =
 				TypeloadModule.ModuleLevel.add_module ctx m p;
 				PMap.iter (Hashtbl.replace com.resources) m.m_extra.m_binded_res;
 				PMap.iter (fun _ (sign,mpath) ->
-					let m2 = find_or_restore_module com.cs sign ctx mpath in
+					let m2 = find_or_restore_module local_module_lut com.cs sign ctx mpath in
 					assert (m2.m_extra.m_sign == sign);
 					add_modules (tabs ^ "  ") m0 m2
 				) m.m_extra.m_deps
 			)
 		end
 	in
-	add_modules "" m m
+	add_modules "" m m;
+	let com_sign = CommonCache.get_cache_sign com in
+	local_module_lut#iter (fun (sign, path) m ->
+		trace (Printf.sprintf "Adding module %s from hxb cache" (s_type_path path));
+		(if sign = com_sign then com else Option.get (com.get_macros())).module_lut#add path m
+	);
+	local_module_lut#clear
 
 (* Looks up the module referred to by [mpath] in the cache. If it exists, a check is made to
    determine if it's still valid. If this function returns None, the module is re-typed. *)
 let type_module sctx (ctx:Typecore.typer) mpath p =
 	let t = Timer.timer ["server";"module cache"] in
 	let com = ctx.Typecore.com in
+	let local_module_lut = new Lookup.hashtbl_lookup in
+
 	try
-		let m = find_or_restore_module com.cs (CommonCache.get_cache_sign com) ctx mpath in
+		let m = find_or_restore_module local_module_lut com.cs (CommonCache.get_cache_sign com) ctx mpath in
 		let tcheck = Timer.timer ["server";"module cache";"check"] in
-		begin match check_module sctx ctx m p with
+		begin match check_module local_module_lut sctx ctx m p with
 		| None -> ()
 		| Some reason ->
 			tcheck();
@@ -452,7 +479,7 @@ let type_module sctx (ctx:Typecore.typer) mpath p =
 		end;
 		tcheck();
 		let tadd = Timer.timer ["server";"module cache";"add modules"] in
-		add_modules sctx ctx m p;
+		add_modules local_module_lut sctx ctx m p;
 		tadd();
 		t();
 		Some m

src/context/display/displayJson.ml

@@ -185,7 +185,8 @@ let handler =
 			let cs = hctx.display#get_cs in
 			let cc = cs#get_context sign in
 			let m = try
-				HxbRestore.find cs sign hctx.com path
+				let local_module_lut = new Lookup.hashtbl_lookup in
+				HxbRestore.find local_module_lut cs sign hctx.com path
 			with Not_found ->
 				hctx.send_error [jstring "No such module"]
 			in
@@ -196,7 +197,8 @@ let handler =
 			let path = Path.parse_path (hctx.jsonrpc#get_string_param "modulePath") in
 			let typeName = hctx.jsonrpc#get_string_param "typeName" in
 			let m = try
-				HxbRestore.find hctx.display#get_cs sign hctx.com path
+				let local_module_lut = new Lookup.hashtbl_lookup in
+				HxbRestore.find local_module_lut hctx.display#get_cs sign hctx.com path
 			with Not_found ->
 				hctx.send_error [jstring "No such module"]
 			in

src/core/json/genjson.ml

@@ -717,7 +717,8 @@ let generate_module cs cc m =
 		"cacheState",jstring (match m.m_extra.m_cache_state with
 			| MSGood -> "Good"
 			| MSBad reason -> Printer.s_module_skip_reason reason
-			| MSUnknown -> "Unknown");
+			| MSUnknown -> "Unknown"
+			| MSRestored _ -> "Restored");
 		"dependencies",jarray (PMap.fold (fun (sign,mpath) acc ->
 			(jobject [
 				"path",jstring (s_type_path mpath);

src/core/tPrinting.ml

@@ -597,10 +597,11 @@ module Printer = struct
 		in
 		loop [] reason
 
-	let s_module_cache_state = function
+	let rec s_module_cache_state = function
 		| MSGood -> "Good"
 		| MSBad reason -> "Bad: " ^ (s_module_skip_reason reason)
 		| MSUnknown -> "Unknown"
+		| MSRestored s -> Printf.sprintf "Restored (%s)" (s_module_cache_state s)
 
 	let s_module_def_extra tabs me =
 		s_record_fields tabs [

src/core/tType.ml

@@ -45,6 +45,7 @@ type module_cache_state =
 	| MSGood
 	| MSBad of module_skip_reason
 	| MSUnknown
+	| MSRestored of module_cache_state
 
 type t =
 	| TMono of tmono

src/filters/exceptions.ml

@@ -599,7 +599,8 @@ let insert_save_stacks tctx =
 		let native_stack_trace_cls =
 			(* let tp = mk_type_path (["haxe"],"NativeStackTrace") in *)
 			(* match Typeload.load_type_def tctx null_pos tp with *)
-			match HxbRestore.find_type tctx.com.cs (CommonCache.get_cache_sign tctx.com) tctx.com (["haxe"], "NativeStackTrace") with
+			let local_module_lut = new Lookup.hashtbl_lookup in
+			match HxbRestore.find_type local_module_lut tctx.com.cs (CommonCache.get_cache_sign tctx.com) tctx.com (["haxe"], "NativeStackTrace") with
 			| TClassDecl cls -> cls
 			| TAbstractDecl { a_impl = Some cls } -> cls
 			| _ -> raise_typing_error "haxe.NativeStackTrace is expected to be a class or an abstract" null_pos

src/typing/typeloadModule.ml

@@ -810,6 +810,7 @@ let type_module_hook = ref (fun _ _ _ -> None)
 let rec get_reader ctx g p =
 	(* TODO: create typer context for this module? *)
 	(* let ctx = create_typer_context_for_module tctx m in *)
+	let local_module_lut = new Lookup.hashtbl_lookup in
 
 	let make_module path file =
 		let m = ModuleLevel.make_module ctx path file in
@@ -828,7 +829,7 @@ let rec get_reader ctx g p =
 	in
 
 	let resolve_type sign pack mname tname =
-		let m = try HxbRestore.find ctx.Typecore.com.cs sign ctx.Typecore.com (pack,mname)
+		let m = try HxbRestore.find local_module_lut ctx.Typecore.com.cs sign ctx.Typecore.com (pack,mname)
 		with Not_found -> load_module' ctx g (pack,mname) p in
 		List.find (fun t -> snd (t_path t) = tname) m.m_types
 	in