[hxb] restore modules from correct cache

src/compiler/hxb/hxbReader.ml

@@ -23,7 +23,7 @@ class hxb_reader
 	(* (file_ch : IO.input) *)
 	(make_module : path -> string -> module_def)
 	(add_module : module_def -> unit)
-	(resolve_type : string list -> string -> string -> module_type)
+	(resolve_type : string -> string list -> string -> string -> module_type)
 	(flush_fields : unit -> unit)
 = object(self)
 
@@ -44,8 +44,8 @@ class hxb_reader
 	val mutable field_type_parameters = Array.make 0 (mk_type_param "" t_dynamic None)
 	val mutable local_type_parameters = Array.make 0 (mk_type_param "" t_dynamic None)
 
-	method resolve_type pack mname tname =
-		try resolve_type pack mname tname with
+	method resolve_type sign pack mname tname =
+		try resolve_type sign 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)))
 
@@ -54,7 +54,7 @@ class hxb_reader
 		match tvoid with
 		| Some tvoid -> tvoid
 		| None ->
-				let t = type_of_module_type (self#resolve_type [] "StdTypes" "Void") in
+				let t = type_of_module_type (self#resolve_type m.m_extra.m_sign [] "StdTypes" "Void") in
 				tvoid <- Some t;
 				t
 
@@ -1041,7 +1041,8 @@ class hxb_reader
 			| 125 ->
 				let e1 = self#read_texpr in
 				let (pack,mname,tname) = self#read_full_path in
-				let md = self#resolve_type pack mname tname in
+				let sign = self#read_string in
+				let md = self#resolve_type sign pack mname tname in
 				TCast(e1,Some md)
 			| 126 ->
 				let c = self#read_class_ref in
@@ -1365,7 +1366,8 @@ class hxb_reader
 		let l = self#read_uleb128 in
 		classes <- (Array.init l (fun i ->
 				let (pack,mname,tname) = self#read_full_path in
-				match self#resolve_type pack mname tname with
+				let sign = self#read_string in
+				match self#resolve_type sign pack mname tname with
 				| TClassDecl c ->
 					c
 				| _ ->
@@ -1376,7 +1378,8 @@ class hxb_reader
 		let l = self#read_uleb128 in
 		abstracts <- (Array.init l (fun i ->
 			let (pack,mname,tname) = self#read_full_path in
-			match self#resolve_type pack mname tname with
+			let sign = self#read_string in
+			match self#resolve_type sign pack mname tname with
 			| TAbstractDecl a ->
 				a
 			| _ ->
@@ -1387,7 +1390,8 @@ class hxb_reader
 		let l = self#read_uleb128 in
 		enums <- (Array.init l (fun i ->
 			let (pack,mname,tname) = self#read_full_path in
-			match self#resolve_type pack mname tname with
+			let sign = self#read_string in
+			match self#resolve_type sign pack mname tname with
 			| TEnumDecl en ->
 				en
 			| _ ->
@@ -1398,7 +1402,8 @@ class hxb_reader
 		let l = self#read_uleb128 in
 		typedefs <- (Array.init l (fun i ->
 			let (pack,mname,tname) = self#read_full_path in
-			match self#resolve_type pack mname tname with
+			let sign = self#read_string in
+			match self#resolve_type sign pack mname tname with
 			| TTypeDecl tpd ->
 				tpd
 			| _ ->

src/compiler/hxb/hxbRestore.ml

@@ -2,29 +2,31 @@ open Globals
 open Type
 
 class hxb_restore
-	(cc : CompilationCache.context_cache)
+	(cs : CompilationCache.t)
 	(com : Common.context)
 = object(self)
 
-	method find (path : path) =
+	method find (path : path) (sign : string) =
 		try begin
 			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 ->
+			let cc = cs#get_context sign in
 			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_extra = { m_cache_state = MSBad reason }} -> raise (Bad_module (path, reason))
-					| Some mc -> self#load mc
+					| Some mc -> self#load cc mc
 				end
 
-	method load (mc : module_cache) =
+	method load (cc : CompilationCache.context_cache) (mc : module_cache) =
 		let reader = new HxbReader.hxb_reader (self#make_module mc) self#add_module self#resolve_type (fun () -> ()) in
 		try reader#read (IO.input_bytes mc.mc_bytes) true null_pos with
 		| Bad_module (path, reason) ->
@@ -32,8 +34,12 @@ class hxb_restore
 			com.module_lut#remove mc.mc_path;
 			(* com.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;
+			raise (HxbData.HxbFailure e)
 		| e ->
-			ServerMessage.debug_msg (Printf.sprintf "[1] Error loading %s from hxb" (s_type_path mc.mc_path));
+			ServerMessage.debug_msg (Printf.sprintf "Error loading %s from hxb" (s_type_path mc.mc_path));
 			com.module_lut#remove mc.mc_path;
 			raise e
 
@@ -44,10 +50,10 @@ class hxb_restore
 		ServerMessage.reusing com "" m;
 		com.module_lut#add m.m_path m
 
-	method resolve_type (pack : string list) (mname : string) (tname : string) =
+	method resolve_type (sign : string) (pack : string list) (mname : string) (tname : string) =
 		let path = (pack,mname) in
 		try
-			let m = try self#find path with Not_found -> print_endline "cannot find module"; raise Not_found in
+			let m = try self#find path sign with Not_found -> print_endline "cannot find module"; raise Not_found in
 			List.find (fun t -> snd (t_path t) = tname) m.m_types
 		with
 			| Bad_module (_, reason) -> raise (Bad_module (path, reason))
@@ -69,11 +75,11 @@ class hxb_restore
 
 end
 
-let find (cc : CompilationCache.context_cache) (com : Common.context) (path : path) =
-	let loader = new hxb_restore cc com in
-	loader#find path
+let find (cs : CompilationCache.t) (sign : string) (com : Common.context) (path : path) =
+	let loader = new hxb_restore cs com in
+	loader#find path sign
 
-let find_type (cc : CompilationCache.context_cache) (com : Common.context) (path : path) =
-	let m = find cc com path in
+let find_type (cs : CompilationCache.t) (sign : string) (com : Common.context) (path : path) =
+	let m = find cs sign com path in
 	List.find (fun t -> snd (t_path t) = (snd path)) m.m_types
 

src/compiler/hxb/hxbWriter.ml

@@ -1078,6 +1078,7 @@ class ['a] hxb_writer
 				let infos = t_infos md in
 				let m = infos.mt_module in
 				self#write_full_path (fst m.m_path) (snd m.m_path) (snd infos.mt_path);
+				chunk#write_string m.m_extra.m_sign;
 			| TNew(({cl_kind = KTypeParameter _} as c),tl,el) ->
 				chunk#write_byte 127;
 				self#write_type_parameter_ref c;
@@ -1550,7 +1551,8 @@ class ['a] hxb_writer
 			chunk#write_list l (fun c ->
 				let m = c.cl_module in
 				(* debug_msg (Printf.sprintf "  [cls] Write full path %s" (ExtString.String.join "." ((fst m.m_path) @ [(snd m.m_path); (snd c.cl_path)]))); *)
-				self#write_full_path (fst m.m_path) (snd m.m_path) (snd c.cl_path)
+				self#write_full_path (fst m.m_path) (snd m.m_path) (snd c.cl_path);
+				chunk#write_string m.m_extra.m_sign
 			)
 		end;
 		begin match abstracts#to_list with
@@ -1561,7 +1563,8 @@ class ['a] hxb_writer
 			chunk#write_list l (fun a ->
 				let m = a.a_module in
 				(* debug_msg (Printf.sprintf "  [abs] Write full path %s" (ExtString.String.join "." ((fst m.m_path) @ [(snd m.m_path); (snd a.a_path)]))); *)
-				self#write_full_path (fst m.m_path) (snd m.m_path) (snd a.a_path)
+				self#write_full_path (fst m.m_path) (snd m.m_path) (snd a.a_path);
+				chunk#write_string m.m_extra.m_sign
 			)
 		end;
 		begin match enums#to_list with
@@ -1572,7 +1575,8 @@ class ['a] hxb_writer
 			chunk#write_list l (fun en ->
 				let m = en.e_module in
 				(* debug_msg (Printf.sprintf "  [enm] Write full path %s" (ExtString.String.join "." ((fst m.m_path) @ [(snd m.m_path); (snd en.e_path)]))); *)
-				self#write_full_path (fst m.m_path) (snd m.m_path) (snd en.e_path)
+				self#write_full_path (fst m.m_path) (snd m.m_path) (snd en.e_path);
+				chunk#write_string m.m_extra.m_sign
 			)
 		end;
 		begin match typedefs#to_list with
@@ -1583,7 +1587,8 @@ class ['a] hxb_writer
 			chunk#write_list l (fun td ->
 				let m = td.t_module in
 				(* debug_msg (Printf.sprintf "  [tpdr] Write full path %s" (ExtString.String.join "." ((fst m.m_path) @ [(snd m.m_path); (snd td.t_path)]))); *)
-				self#write_full_path (fst m.m_path) (snd m.m_path) (snd td.t_path)
+				self#write_full_path (fst m.m_path) (snd m.m_path) (snd td.t_path);
+				chunk#write_string m.m_extra.m_sign
 			)
 		end;
 		self#start_chunk HHDR;

src/compiler/server.ml

@@ -220,8 +220,8 @@ let get_changed_directories sctx (ctx : Typecore.typer) =
 	t();
 	dirs
 
-let find_or_restore_module (cc : context_cache) ctx path =
-	HxbRestore.find cc ctx.Typecore.com path
+let find_or_restore_module cs sign ctx path =
+	HxbRestore.find cs sign ctx.Typecore.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. *)
@@ -312,7 +312,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#get_context sign) ctx mpath with Bad_module (_, reason) -> raise (Dirty (DependencyDirty(mpath,reason))) in
+				let m2 = try find_or_restore_module 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)))
@@ -414,7 +414,7 @@ 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#get_context sign) ctx mpath in
+					let m2 = find_or_restore_module com.cs sign ctx mpath in
 					assert (m2.m_extra.m_sign == sign);
 					add_modules (tabs ^ "  ") m0 m2
 				) m.m_extra.m_deps
@@ -428,9 +428,8 @@ let add_modules sctx ctx m p =
 let type_module sctx (ctx:Typecore.typer) mpath p =
 	let t = Timer.timer ["server";"module cache"] in
 	let com = ctx.Typecore.com in
-	let cc = CommonCache.get_cache com in
 	try
-		let m = find_or_restore_module cc ctx mpath in
+		let m = find_or_restore_module 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
 		| None -> ()

src/context/commonCache.ml

@@ -69,6 +69,10 @@ let get_cache com = match com.Common.cache with
 	| Some cache ->
 		cache
 
+let get_cache_sign com = match com.Common.cache with
+	| None -> Define.get_signature com.defines
+	| Some cache -> cache#get_sign
+
 let rec cache_context cs com =
 	let cc = get_cache com in
 	let sign = Define.get_signature com.defines in

src/context/display/displayJson.ml

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

src/filters/exceptions.ml

@@ -599,7 +599,7 @@ 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 (CommonCache.get_cache tctx.com) tctx.com (["haxe"], "NativeStackTrace") with
+			match HxbRestore.find_type 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

@@ -816,9 +816,8 @@ let rec get_reader ctx =
 		flush_pass ctx PConnectField "hxb"
 	in
 
-	let resolve_type pack mname tname =
-		let cc = CommonCache.get_cache ctx.Typecore.com in
-		let m = HxbRestore.find cc ctx.Typecore.com (pack,mname) in
+	let resolve_type sign pack mname tname =
+		let m = HxbRestore.find ctx.Typecore.com.cs sign ctx.Typecore.com (pack,mname) in
 		List.find (fun t -> snd (t_path t) = tname) m.m_types
 	in