diff --git a/src/codegen/codegen.ml b/src/codegen/codegen.ml index 84509ec8276..c4b211a1158 100644 --- a/src/codegen/codegen.ml +++ b/src/codegen/codegen.ml @@ -387,7 +387,8 @@ module Dump = struct let dep = Hashtbl.create 0 in List.iter (fun m -> print "%s:\n" (Path.UniqueKey.lazy_path m.m_extra.m_file); - PMap.iter (fun _ m2 -> + PMap.iter (fun _ (sign,mpath) -> + let m2 = (com.cs#get_context sign)#find_module mpath in let file = Path.UniqueKey.lazy_path m2.m_extra.m_file in print "\t%s\n" file; let l = try Hashtbl.find dep file with Not_found -> [] in diff --git a/src/compiler/server.ml b/src/compiler/server.ml index 105bf636077..47076beb92b 100644 --- a/src/compiler/server.ml +++ b/src/compiler/server.ml @@ -307,7 +307,9 @@ let check_module sctx ctx m p = end in let check_dependencies () = - PMap.iter (fun _ m2 -> match check m2 with + PMap.iter (fun _ (sign,mpath) -> + let m2 = (com.cs#get_context sign)#find_module mpath in + match check m2 with | None -> () | Some reason -> raise (Dirty (DependencyDirty(m2.m_path,reason))) ) m.m_extra.m_deps; @@ -407,7 +409,10 @@ let add_modules sctx ctx m p = ) m.m_types; TypeloadModule.ModuleLevel.add_module ctx m p; PMap.iter (Hashtbl.replace com.resources) m.m_extra.m_binded_res; - PMap.iter (fun _ m2 -> add_modules (tabs ^ " ") m0 m2) m.m_extra.m_deps + PMap.iter (fun _ (sign,mpath) -> + let m2 = (com.cs#get_context sign)#find_module mpath in + add_modules (tabs ^ " ") m0 m2 + ) m.m_extra.m_deps ) end in diff --git a/src/context/display/displayJson.ml b/src/context/display/displayJson.ml index 06a336c8aac..1ed9e25cd25 100644 --- a/src/context/display/displayJson.ml +++ b/src/context/display/displayJson.ml @@ -182,13 +182,14 @@ let handler = "server/module", (fun hctx -> let sign = Digest.from_hex (hctx.jsonrpc#get_string_param "signature") in let path = Path.parse_path (hctx.jsonrpc#get_string_param "path") in - let cc = hctx.display#get_cs#get_context sign in + let cs = hctx.display#get_cs in + let cc = cs#get_context sign in let m = try cc#find_module path with Not_found -> hctx.send_error [jstring "No such module"] in - hctx.send_result (generate_module cc m) + hctx.send_result (generate_module cs cc m) ); "server/type", (fun hctx -> let sign = Digest.from_hex (hctx.jsonrpc#get_string_param "signature") in diff --git a/src/context/memory.ml b/src/context/memory.ml index 9b692d344d9..8d16ca17ffe 100644 --- a/src/context/memory.ml +++ b/src/context/memory.ml @@ -33,12 +33,14 @@ let update_module_type_deps deps md = ) md.m_types; !deps -let rec scan_module_deps m h = +let rec scan_module_deps cs m h = if Hashtbl.mem h m.m_id then () else begin Hashtbl.add h m.m_id m; - PMap.iter (fun _ m -> scan_module_deps m h) m.m_extra.m_deps + PMap.iter (fun _ (sign,mpath) -> + let m = (cs#get_context sign)#find_module mpath in + scan_module_deps cs m h) m.m_extra.m_deps end let module_sign key md = @@ -61,7 +63,7 @@ let get_out out = let get_module_memory cs all_modules m = let mdeps = Hashtbl.create 0 in - scan_module_deps m mdeps; + scan_module_deps cs m mdeps; let deps = ref [Obj.repr null_module] in let out = ref all_modules in let deps = Hashtbl.fold (fun _ md deps -> @@ -272,8 +274,9 @@ let display_memory com = ()); if verbose then begin print (Printf.sprintf " %d total deps" (List.length deps)); - PMap.iter (fun _ md -> - print (Printf.sprintf " dep %s%s" (s_type_path md.m_path) (module_sign key md)); + PMap.iter (fun _ (sign,mpath) -> + let md = (com.cs#get_context sign)#find_module mpath in + print (Printf.sprintf " dep %s%s" (s_type_path mpath) (module_sign key md)); ) m.m_extra.m_deps; end; flush stdout diff --git a/src/core/json/genjson.ml b/src/core/json/genjson.ml index ed85b04a7a1..c3f79615fdf 100644 --- a/src/core/json/genjson.ml +++ b/src/core/json/genjson.ml @@ -707,7 +707,7 @@ let generate_module_type ctx mt = (* module *) -let generate_module cc m = +let generate_module cs cc m = jobject [ "id",jint m.m_id; "path",generate_module_path m.m_path; @@ -718,10 +718,12 @@ let generate_module cc m = | MSGood -> "Good" | MSBad reason -> Printer.s_module_skip_reason reason | MSUnknown -> "Unknown"); - "dependencies",jarray (PMap.fold (fun m acc -> (jobject [ - "path",jstring (s_type_path m.m_path); - "sign",jstring (Digest.to_hex m.m_extra.m_sign); - ]) :: acc) m.m_extra.m_deps []); + "dependencies",jarray (PMap.fold (fun (sign,mpath) acc -> + (jobject [ + "path",jstring (s_type_path mpath); + "sign",jstring (Digest.to_hex ((cs#get_context sign)#find_module mpath).m_extra.m_sign); + ]) :: acc + ) m.m_extra.m_deps []); "dependents",jarray (List.map (fun m -> (jobject [ "path",jstring (s_type_path m.m_path); "sign",jstring (Digest.to_hex m.m_extra.m_sign); diff --git a/src/core/tFunctions.ml b/src/core/tFunctions.ml index 2879e5ff212..ff3540b08ef 100644 --- a/src/core/tFunctions.ml +++ b/src/core/tFunctions.ml @@ -233,8 +233,8 @@ let null_abstract = { } let add_dependency ?(skip_postprocess=false) m mdep = - if m != null_module && m != mdep then begin - m.m_extra.m_deps <- PMap.add mdep.m_id mdep m.m_extra.m_deps; + if m != null_module && (m.m_path != mdep.m_path || m.m_extra.m_sign != mdep.m_extra.m_sign) then begin + m.m_extra.m_deps <- PMap.add mdep.m_id (mdep.m_extra.m_sign, mdep.m_path) m.m_extra.m_deps; (* In case the module is cached, we'll have to run post-processing on it again (issue #10635) *) if not skip_postprocess then m.m_extra.m_processed <- 0 end diff --git a/src/core/tPrinting.ml b/src/core/tPrinting.ml index 74a8949bbb0..fd4351ea0a2 100644 --- a/src/core/tPrinting.ml +++ b/src/core/tPrinting.ml @@ -605,7 +605,7 @@ module Printer = struct "m_cache_state",s_module_cache_state me.m_cache_state; "m_added",string_of_int me.m_added; "m_checked",string_of_int me.m_checked; - "m_deps",s_pmap string_of_int (fun m -> snd m.m_path) me.m_deps; + "m_deps",s_pmap string_of_int (fun (_,m) -> snd m) me.m_deps; "m_processed",string_of_int me.m_processed; "m_kind",s_module_kind me.m_kind; "m_binded_res",""; (* TODO *) diff --git a/src/core/tType.ml b/src/core/tType.ml index dd328432ebb..6ec5f025b21 100644 --- a/src/core/tType.ml +++ b/src/core/tType.ml @@ -390,7 +390,7 @@ and module_def_extra = { mutable m_added : int; mutable m_checked : int; mutable m_processed : int; - mutable m_deps : (int,module_def) PMap.t; + mutable m_deps : (int,(string (* sign *) * path)) PMap.t; mutable m_kind : module_kind; mutable m_binded_res : (string, string) PMap.t; mutable m_if_feature : (string *(tclass * tclass_field * bool)) list;