Permalink
Browse files

weak dependencies with -trans-mod (github/ocamllabs/weak-depends 45e980a

,21856a7,merge)

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14719 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
  • Loading branch information...
1 parent f8df3c9 commit 521ac0213a11a22ca9e7dd588d7274072eb8e094 @mshinwell mshinwell committed May 1, 2014
View
51 asmcomp/asmlink.ml
@@ -33,31 +33,37 @@ exception Error of error
(* Consistency check between interfaces and implementations *)
let crc_interfaces = Consistbl.create ()
+let interfaces = ref ([] : string list)
let crc_implementations = Consistbl.create ()
-let extra_implementations = ref ([] : string list)
+let implementations = ref ([] : string list)
let implementations_defined = ref ([] : (string * string) list)
let cmx_required = ref ([] : string list)
let check_consistency file_name unit crc =
begin try
List.iter
- (fun (name, crc) ->
- if name = unit.ui_name
- then Consistbl.set crc_interfaces name crc file_name
- else Consistbl.check crc_interfaces name crc file_name)
+ (fun (name, crco) ->
+ interfaces := name :: !interfaces;
+ match crco with
+ None -> ()
+ | Some crc ->
+ if name = unit.ui_name
+ then Consistbl.set crc_interfaces name crc file_name
+ else Consistbl.check crc_interfaces name crc file_name)
unit.ui_imports_cmi
with Consistbl.Inconsistency(name, user, auth) ->
raise(Error(Inconsistent_interface(name, user, auth)))
end;
begin try
List.iter
- (fun (name, crc) ->
- if crc <> cmx_not_found_crc then
- Consistbl.check crc_implementations name crc file_name
- else if List.mem name !cmx_required then
- raise(Error(Missing_cmx(file_name, name)))
- else
- extra_implementations := name :: !extra_implementations)
+ (fun (name, crco) ->
+ implementations := name :: !implementations;
+ match crco with
+ None ->
+ if List.mem name !cmx_required then
+ raise(Error(Missing_cmx(file_name, name)))
+ | Some crc ->
+ Consistbl.check crc_implementations name crc file_name)
unit.ui_imports_cmx
with Consistbl.Inconsistency(name, user, auth) ->
raise(Error(Inconsistent_implementation(name, user, auth)))
@@ -67,20 +73,17 @@ let check_consistency file_name unit crc =
raise (Error(Multiple_definition(unit.ui_name, file_name, source)))
with Not_found -> ()
end;
+ implementations := unit.ui_name :: !implementations;
Consistbl.set crc_implementations unit.ui_name crc file_name;
implementations_defined :=
(unit.ui_name, file_name) :: !implementations_defined;
if unit.ui_symbol <> unit.ui_name then
cmx_required := unit.ui_name :: !cmx_required
let extract_crc_interfaces () =
- Consistbl.extract crc_interfaces
+ Consistbl.extract !interfaces crc_interfaces
let extract_crc_implementations () =
- List.fold_left
- (fun ncl n ->
- if List.mem_assoc n ncl then ncl else (n, cmx_not_found_crc) :: ncl)
- (Consistbl.extract crc_implementations)
- !extra_implementations
+ Consistbl.extract !implementations crc_implementations
(* Add C objects and options and "custom" info from a library descriptor.
See bytecomp/bytelink.ml for comments on the order of C objects. *)
@@ -214,10 +217,14 @@ let make_startup_file ppf filename units_list =
(Cmmgen.globals_map
(List.map
(fun (unit,_,crc) ->
- try (unit.ui_name, List.assoc unit.ui_name unit.ui_imports_cmi,
- crc,
- unit.ui_defines)
- with Not_found -> assert false)
+ let intf_crc =
+ try
+ match List.assoc unit.ui_name unit.ui_imports_cmi with
+ None -> assert false
+ | Some crc -> crc
+ with Not_found -> assert false
+ in
+ (unit.ui_name, intf_crc, crc, unit.ui_defines))
units_list));
compile_phrase(Cmmgen.data_segment_table ("_startup" :: name_list));
compile_phrase(Cmmgen.code_segment_table ("_startup" :: name_list));
View
4 asmcomp/asmlink.mli
@@ -21,8 +21,8 @@ val link_shared: formatter -> string list -> string -> unit
val call_linker_shared: string list -> string -> unit
val check_consistency: string -> Cmx_format.unit_infos -> Digest.t -> unit
-val extract_crc_interfaces: unit -> (string * Digest.t) list
-val extract_crc_implementations: unit -> (string * Digest.t) list
+val extract_crc_interfaces: unit -> (string * Digest.t option) list
+val extract_crc_implementations: unit -> (string * Digest.t option) list
type error =
File_not_found of string
View
2 asmcomp/asmpackager.ml
@@ -130,7 +130,7 @@ let build_package_cmx members cmxfile =
List.flatten (List.map (fun info -> info.ui_defines) units) @
[ui.ui_symbol];
ui_imports_cmi =
- (ui.ui_name, Env.crc_of_unit ui.ui_name) ::
+ (ui.ui_name, Some (Env.crc_of_unit ui.ui_name)) ::
filter(Asmlink.extract_crc_interfaces());
ui_imports_cmx =
filter(Asmlink.extract_crc_implementations());
View
9 asmcomp/cmx_format.mli
@@ -26,8 +26,9 @@ type unit_infos =
{ mutable ui_name: string; (* Name of unit implemented *)
mutable ui_symbol: string; (* Prefix for symbols *)
mutable ui_defines: string list; (* Unit and sub-units implemented *)
- mutable ui_imports_cmi: (string * Digest.t) list; (* Interfaces imported *)
- mutable ui_imports_cmx: (string * Digest.t) list; (* Infos imported *)
+ mutable ui_imports_cmi:
+ (string * Digest.t option) list; (* Interfaces imported *)
+ mutable ui_imports_cmx:(string * Digest.t option) list; (* Infos imported *)
mutable ui_approx: Clambda.value_approximation; (* Approx of the structure*)
mutable ui_curry_fun: int list; (* Currying functions needed *)
mutable ui_apply_fun: int list; (* Apply functions needed *)
@@ -49,8 +50,8 @@ type library_infos =
type dynunit = {
dynu_name: string;
dynu_crc: Digest.t;
- dynu_imports_cmi: (string * Digest.t) list;
- dynu_imports_cmx: (string * Digest.t) list;
+ dynu_imports_cmi: (string * Digest.t option) list;
+ dynu_imports_cmx: (string * Digest.t option) list;
dynu_defines: string list;
}
View
9 asmcomp/compilenv.ml
@@ -143,9 +143,6 @@ let read_library_info filename =
(* Read and cache info on global identifiers *)
-let cmx_not_found_crc =
- "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000"
-
let get_global_info global_ident = (
let modname = Ident.name global_ident in
if modname = current_unit.ui_name then
@@ -161,9 +158,9 @@ let get_global_info global_ident = (
let (ui, crc) = read_unit_info filename in
if ui.ui_name <> modname then
raise(Error(Illegal_renaming(modname, ui.ui_name, filename)));
- (Some ui, crc)
+ (Some ui, Some crc)
with Not_found ->
- (None, cmx_not_found_crc) in
+ (None, None) in
current_unit.ui_imports_cmx <-
(modname, crc) :: current_unit.ui_imports_cmx;
Hashtbl.add global_infos_table modname infos;
@@ -231,7 +228,7 @@ let write_unit_info info filename =
close_out oc
let save_unit_info filename =
- current_unit.ui_imports_cmi <- Env.imported_units();
+ current_unit.ui_imports_cmi <- Env.imports();
write_unit_info current_unit filename
View
4 asmcomp/compilenv.mli
@@ -79,10 +79,6 @@ val cache_unit_info: unit_infos -> unit
honored by [symbol_for_global] and [global_approx]
without looking at the corresponding .cmx file. *)
-val cmx_not_found_crc: Digest.t
- (* Special digest used in the [ui_imports_cmx] list to signal
- that no [.cmx] file was found and used for the imported unit *)
-
val read_library_info: string -> library_infos
type error =
View
BIN boot/ocamlc
Binary file not shown.
View
BIN boot/ocamldep
Binary file not shown.
View
BIN boot/ocamllex
Binary file not shown.
View
23 bytecomp/bytelink.ml
@@ -158,15 +158,20 @@ let scan_file obj_name tolink =
(* Consistency check between interfaces *)
let crc_interfaces = Consistbl.create ()
+let interfaces = ref ([] : string list)
let implementations_defined = ref ([] : (string * string) list)
let check_consistency ppf file_name cu =
begin try
List.iter
- (fun (name, crc) ->
- if name = cu.cu_name
- then Consistbl.set crc_interfaces name crc file_name
- else Consistbl.check crc_interfaces name crc file_name)
+ (fun (name, crco) ->
+ interfaces := name :: !interfaces;
+ match crco with
+ None -> ()
+ | Some crc ->
+ if name = cu.cu_name
+ then Consistbl.set crc_interfaces name crc file_name
+ else Consistbl.check crc_interfaces name crc file_name)
cu.cu_imports
with Consistbl.Inconsistency(name, user, auth) ->
raise(Error(Inconsistent_import(name, user, auth)))
@@ -183,7 +188,11 @@ let check_consistency ppf file_name cu =
(cu.cu_name, file_name) :: !implementations_defined
let extract_crc_interfaces () =
- Consistbl.extract crc_interfaces
+ Consistbl.extract !interfaces crc_interfaces
+
+let clear_crc_interfaces () =
+ Consistbl.clear crc_interfaces;
+ interfaces := []
(* Record compilation events *)
@@ -307,7 +316,7 @@ let link_bytecode ppf tolink exec_name standalone =
(* The bytecode *)
let start_code = pos_out outchan in
Symtable.init();
- Consistbl.clear crc_interfaces;
+ clear_crc_interfaces ();
let sharedobjs = List.map Dll.extract_dll_name !Clflags.dllibs in
let check_dlls = standalone && Config.target = Config.host in
if check_dlls then begin
@@ -440,7 +449,7 @@ let link_bytecode_as_c ppf tolink outfile =
\n char **argv);\n";
output_string outchan "static int caml_code[] = {\n";
Symtable.init();
- Consistbl.clear crc_interfaces;
+ clear_crc_interfaces ();
let currpos = ref 0 in
let output_fun code =
output_code_string outchan code;
View
2 bytecomp/bytelink.mli
@@ -17,7 +17,7 @@ val link : Format.formatter -> string list -> string -> unit
val check_consistency:
Format.formatter -> string -> Cmo_format.compilation_unit -> unit
-val extract_crc_interfaces: unit -> (string * Digest.t) list
+val extract_crc_interfaces: unit -> (string * Digest.t option) list
type error =
File_not_found of string
View
3 bytecomp/bytepackager.ml
@@ -235,7 +235,8 @@ let package_object_files ppf files targetfile targetname coercion =
cu_pos = pos_code;
cu_codesize = pos_debug - pos_code;
cu_reloc = List.rev !relocs;
- cu_imports = (targetname, Env.crc_of_unit targetname) :: imports;
+ cu_imports =
+ (targetname, Some (Env.crc_of_unit targetname)) :: imports;
cu_primitives = !primitives;
cu_force_link = !force_link;
cu_debug = if pos_final > pos_debug then pos_debug else 0;
View
3 bytecomp/cmo_format.mli
@@ -27,7 +27,8 @@ type compilation_unit =
mutable cu_pos: int; (* Absolute position in file *)
cu_codesize: int; (* Size of code block *)
cu_reloc: (reloc_info * int) list; (* Relocation information *)
- cu_imports: (string * Digest.t) list; (* Names and CRC of intfs imported *)
+ cu_imports:
+ (string * Digest.t option) list; (* Names and CRC of intfs imported *)
cu_primitives: string list; (* Primitives declared inside *)
mutable cu_force_link: bool; (* Must be linked even if unref'ed *)
mutable cu_debug: int; (* Position of debugging info, or 0 *)
View
2 bytecomp/emitcode.ml
@@ -381,7 +381,7 @@ let to_file outchan unit_name code =
cu_pos = pos_code;
cu_codesize = !out_position;
cu_reloc = List.rev !reloc_info;
- cu_imports = Env.imported_units();
+ cu_imports = Env.imports();
cu_primitives = List.map Primitive.byte_name
!Translmod.primitive_declarations;
cu_force_link = false;
View
2 bytecomp/symtable.ml
@@ -300,7 +300,7 @@ let init_toplevel () =
Dll.init_toplevel dllpath;
(* Recover CRC infos for interfaces *)
let crcintfs =
- try (Obj.magic (sect.read_struct "CRCS") : (string * Digest.t) list)
+ try (Obj.magic (sect.read_struct "CRCS") : (string * Digest.t option) list)
with Not_found -> [] in
(* Done *)
sect.close_reader();
View
2 bytecomp/symtable.mli
@@ -29,7 +29,7 @@ val data_primitive_names: unit -> string
(* Functions for the toplevel *)
-val init_toplevel: unit -> (string * Digest.t) list
+val init_toplevel: unit -> (string * Digest.t option) list
val update_global_table: unit -> unit
val get_global_value: Ident.t -> Obj.t
val is_global_defined: Ident.t -> bool
View
2 driver/main_args.ml
@@ -275,7 +275,7 @@ let mk_thread f =
let mk_trans_mod f =
"-trans-mod", Arg.Unit f,
- " Make typing and linking only depend on normalized paths"
+ " Do not import unused module aliases"
let mk_unsafe f =
"-unsafe", Arg.Unit f,
View
3 man/ocamlc.m
@@ -538,6 +538,9 @@ Build a bytecode object file (.cmo file) and its associated compiled
system "threads" library described in
.IR The\ OCaml\ user's\ manual .
.TP
+.B \-trans-mod
+Do not import unused module aliases.
+.TP
.B \-unsafe
Turn bound checking off for array and string accesses (the
.BR v.(i) and s.[i]
View
3 man/ocamlopt.m
@@ -512,6 +512,9 @@ apply to the way the extra native objects have been compiled (under
system threads library described in
.IR "The OCaml user's manual" .
.TP
+.B \-trans-mod
+Do not import unused module aliases.
+.TP
.B \-unsafe
Turn bound checking off for array and string accesses (the
.BR v.(i) and s.[i]
View
31 otherlibs/dynlink/dynlink.ml
@@ -79,13 +79,16 @@ let allow_extension = ref true
let check_consistency file_name cu =
try
List.iter
- (fun (name, crc) ->
- if name = cu.cu_name then
- Consistbl.set !crc_interfaces name crc file_name
- else if !allow_extension then
- Consistbl.check !crc_interfaces name crc file_name
- else
- Consistbl.check_noadd !crc_interfaces name crc file_name)
+ (fun (name, crco) ->
+ match crco with
+ None -> ()
+ | Some crc ->
+ if name = cu.cu_name then
+ Consistbl.set !crc_interfaces name crc file_name
+ else if !allow_extension then
+ Consistbl.check !crc_interfaces name crc file_name
+ else
+ Consistbl.check_noadd !crc_interfaces name crc file_name)
cu.cu_imports
with Consistbl.Inconsistency(name, user, auth) ->
raise(Error(Inconsistent_import name))
@@ -113,15 +116,21 @@ let prohibit names =
(* Initialize the crc_interfaces table with a list of units with fixed CRCs *)
let add_available_units units =
- List.iter (fun (unit, crc) -> Consistbl.set !crc_interfaces unit crc "")
- units
+ List.iter
+ (fun (unit, crc) -> Consistbl.set !crc_interfaces unit crc "")
+ units
(* Default interface CRCs: those found in the current executable *)
let default_crcs = ref []
let default_available_units () =
clear_available_units();
- add_available_units !default_crcs;
+ List.iter
+ (fun (unit, crco) ->
+ match crco with
+ None -> ()
+ | Some crc -> Consistbl.set !crc_interfaces unit crc "")
+ !default_crcs;
allow_extension := true
(* Initialize the linker tables and everything *)
@@ -163,7 +172,7 @@ let digest_interface unit loadpath =
close_in ic;
let crc =
match cmi.Cmi_format.cmi_crcs with
- (_, crc) :: _ -> crc
+ (_, Some crc) :: _ -> crc
| _ -> raise(Error(Corrupted_interface filename))
in
crc
View
51 otherlibs/dynlink/natdynlink.ml
@@ -41,11 +41,7 @@ exception Error of error
open Cmx_format
(* Copied from config.ml to avoid dependencies *)
-let cmxs_magic_number = "Caml2007D001"
-
-(* Copied from compilenv.ml to avoid dependencies *)
-let cmx_not_found_crc =
- "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000"
+let cmxs_magic_number = "Caml2007D002"
let dll_filename fname =
if Filename.is_implicit fname then Filename.concat (Sys.getcwd ()) fname
@@ -114,23 +110,26 @@ let init () =
let add_check_ifaces allow_ext filename ui ifaces =
List.fold_left
- (fun ifaces (name, crc) ->
- if name = ui.dynu_name
- then StrMap.add name (crc,filename) ifaces
- else
- try
- let (old_crc,old_src) = StrMap.find name ifaces in
- if old_crc <> crc
- then raise(Error(Inconsistent_import(name)))
- else ifaces
- with Not_found ->
- if allow_ext then StrMap.add name (crc,filename) ifaces
- else raise (Error(Unavailable_unit name))
+ (fun ifaces (name, crco) ->
+ match crco with
+ None -> ifaces
+ | Some crc ->
+ if name = ui.dynu_name
+ then StrMap.add name (crc,filename) ifaces
+ else
+ try
+ let (old_crc,old_src) = StrMap.find name ifaces in
+ if old_crc <> crc
+ then raise(Error(Inconsistent_import(name)))
+ else ifaces
+ with Not_found ->
+ if allow_ext then StrMap.add name (crc,filename) ifaces
+ else raise (Error(Unavailable_unit name))
) ifaces ui.dynu_imports_cmi
let check_implems filename ui implems =
List.iter
- (fun (name, crc) ->
+ (fun (name, crco) ->
match name with
|"Out_of_memory"
|"Sys_error"
@@ -147,13 +146,15 @@ let check_implems filename ui implems =
| _ ->
try
let (old_crc,old_src,state) = StrMap.find name implems in
- if crc <> cmx_not_found_crc && old_crc <> crc
- then raise(Error(Inconsistent_implementation(name)))
- else match state with
- | Check_inited i ->
- if ndl_globals_inited() < i
- then raise(Error(Unavailable_unit name))
- | Loaded -> ()
+ match crco with
+ Some crc when old_crc <> crc ->
+ raise(Error(Inconsistent_implementation(name)))
+ | _ ->
+ match state with
+ | Check_inited i ->
+ if ndl_globals_inited() < i
+ then raise(Error(Unavailable_unit name))
+ | Loaded -> ()
with Not_found ->
raise (Error(Unavailable_unit name))
) ui.dynu_imports_cmx
View
13 tools/objinfo.ml
@@ -34,8 +34,15 @@ let input_stringlist ic len =
let sect = really_input_string ic len in
get_string_list sect len
-let print_name_crc (name, crc) =
- printf "\t%s\t%s\n" (Digest.to_hex crc) name
+let dummy_crc = String.make 32 '-'
+
+let print_name_crc (name, crco) =
+ let crc =
+ match crco with
+ None -> dummy_crc
+ | Some crc -> Digest.to_hex crc
+ in
+ printf "\t%s\t%s\n" crc name
let print_line name =
printf "\t%s\n" name
@@ -143,7 +150,7 @@ let dump_byte ic =
| "CRCS" ->
p_section
"Imported units"
- (input_value ic : (string * Digest.t) list)
+ (input_value ic : (string * Digest.t option) list)
| "DLLS" ->
p_list
"Used DLLs"
View
11 tools/read_cmt.ml
@@ -27,6 +27,8 @@ let arg_list = [
let arg_usage =
"read_cmt [OPTIONS] FILE.cmt : read FILE.cmt and print related information"
+let dummy_crc = String.make 32 '-'
+
let print_info cmt =
let open Cmt_format in
Printf.printf "module name: %s\n" cmt.cmt_modname;
@@ -60,8 +62,13 @@ let print_info cmt =
| Some digest ->
Printf.printf "interface digest: %s\n" (Digest.to_hex digest);
end;
- List.iter (fun (name, digest) ->
- Printf.printf "import: %s %s\n" name (Digest.to_hex digest);
+ List.iter (fun (name, crco) ->
+ let crc =
+ match crco with
+ None -> dummy_crc
+ | Some crc -> Digest.to_hex crc
+ in
+ Printf.printf "import: %s %s\n" name crc;
) (List.sort compare cmt.cmt_imports);
Printf.printf "%!";
()
View
2 toplevel/expunge.ml
@@ -65,7 +65,7 @@ let main () =
let global_map = (input_value ic : Symtable.global_map) in
output_value oc (expunge_map global_map)
| "CRCS" ->
- let crcs = (input_value ic : (string * Digest.t) list) in
+ let crcs = (input_value ic : (string * Digest.t option) list) in
output_value oc (expunge_crcs crcs)
| _ ->
copy_file_chunk ic oc len
View
7 toplevel/topdirs.ml
@@ -61,7 +61,12 @@ exception Load_failed
let check_consistency ppf filename cu =
try
List.iter
- (fun (name, crc) -> Consistbl.check Env.crc_units name crc filename)
+ (fun (name, crco) ->
+ Env.imported_units := name :: !Env.imported_units;
+ match crco with
+ None -> ()
+ | Some crc->
+ Consistbl.check Env.crc_units name crc filename)
cu.cu_imports
with Consistbl.Inconsistency(name, user, auth) ->
fprintf ppf "@[<hv 0>The files %s@ and %s@ \
View
8 toplevel/toploop.ml
@@ -424,8 +424,12 @@ let _ =
let crc_intfs = Symtable.init_toplevel() in
Compmisc.init_path false;
List.iter
- (fun (name, crc) ->
- Consistbl.set Env.crc_units name crc Sys.executable_name)
+ (fun (name, crco) ->
+ Env.imported_units := name :: !Env.imported_units;
+ match crco with
+ None -> ()
+ | Some crc->
+ Consistbl.set Env.crc_units name crc Sys.executable_name)
crc_intfs
let load_ocamlinit ppf =
View
4 typing/cmi_format.ml
@@ -22,7 +22,7 @@ exception Error of error
type cmi_infos = {
cmi_name : string;
cmi_sign : Types.signature_item list;
- cmi_crcs : (string * Digest.t) list;
+ cmi_crcs : (string * Digest.t option) list;
cmi_flags : pers_flags list;
}
@@ -72,7 +72,7 @@ let output_cmi filename oc cmi =
output_value oc (cmi.cmi_name, cmi.cmi_sign);
flush oc;
let crc = Digest.file filename in
- let crcs = (cmi.cmi_name, crc) :: cmi.cmi_crcs in
+ let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in
output_value oc crcs;
output_value oc cmi.cmi_flags;
crc
View
2 typing/cmi_format.mli
@@ -15,7 +15,7 @@ type pers_flags = Rectypes
type cmi_infos = {
cmi_name : string;
cmi_sign : Types.signature_item list;
- cmi_crcs : (string * Digest.t) list;
+ cmi_crcs : (string * Digest.t option) list;
cmi_flags : pers_flags list;
}
View
4 typing/cmt_format.ml
@@ -54,7 +54,7 @@ type cmt_infos = {
cmt_loadpath : string list;
cmt_source_digest : Digest.t option;
cmt_initial_env : Env.t;
- cmt_imports : (string * Digest.t) list;
+ cmt_imports : (string * Digest.t option) list;
cmt_interface_digest : Digest.t option;
cmt_use_summaries : bool;
}
@@ -201,7 +201,7 @@ let record_value_dependency vd1 vd2 =
let save_cmt filename modname binary_annots sourcefile initial_env sg =
if !Clflags.binary_annotations && not !Clflags.print_types then begin
- let imports = Env.imported_units () in
+ let imports = Env.imports () in
let oc = open_out_bin filename in
let this_crc =
match sg with
View
2 typing/cmt_format.mli
@@ -57,7 +57,7 @@ type cmt_infos = {
cmt_loadpath : string list;
cmt_source_digest : string option;
cmt_initial_env : Env.t;
- cmt_imports : (string * Digest.t) list;
+ cmt_imports : (string * Digest.t option) list;
cmt_interface_digest : Digest.t option;
cmt_use_summaries : bool;
}
View
42 typing/env.ml
@@ -286,7 +286,7 @@ type pers_struct =
{ ps_name: string;
ps_sig: signature;
ps_comps: module_components;
- ps_crcs: (string * Digest.t) list;
+ ps_crcs: (string * Digest.t option) list;
ps_filename: string;
ps_flags: pers_flags list;
mutable ps_crcs_checked: bool }
@@ -297,12 +297,25 @@ let persistent_structures =
(* Consistency between persistent structures *)
let crc_units = Consistbl.create()
+let imported_units = ref ([] : string list)
+
+let clear_imports () =
+ Consistbl.clear crc_units;
+ imported_units := []
+
+let add_imports ps =
+ List.iter
+ (fun (name, _) -> imported_units := name :: !imported_units)
+ ps.ps_crcs
let check_consistency ps =
if ps.ps_crcs_checked then () else
try
List.iter
- (fun (name, crc) -> Consistbl.check crc_units name crc ps.ps_filename)
+ (fun (name, crco) ->
+ match crco with
+ None -> ()
+ | Some crc -> Consistbl.check crc_units name crc ps.ps_filename)
ps.ps_crcs;
ps.ps_crcs_checked <- true
with Consistbl.Inconsistency(name, source, auth) ->
@@ -330,6 +343,7 @@ let read_pers_struct modname filename =
ps_flags = flags } in
if ps.ps_name <> modname then
error (Illegal_renaming(modname, ps.ps_name, filename));
+ add_imports ps;
if not !Clflags.transparent_modules then check_consistency ps;
List.iter
(function Rectypes ->
@@ -364,7 +378,7 @@ let find_pers_struct ?(check=true) name =
let reset_cache () =
current_unit := "";
Hashtbl.clear persistent_structures;
- Consistbl.clear crc_units;
+ clear_imports ();
Hashtbl.clear value_declarations;
Hashtbl.clear type_declarations;
Hashtbl.clear used_constructors;
@@ -1559,15 +1573,20 @@ let read_signature modname filename =
let crc_of_unit name =
let ps = find_pers_struct ~check:false name in
- try
- List.assoc name ps.ps_crcs
- with Not_found ->
- assert false
+ let crco =
+ try
+ List.assoc name ps.ps_crcs
+ with Not_found ->
+ assert false
+ in
+ match crco with
+ None -> assert false
+ | Some crc -> crc
(* Return the list of imported interfaces with their CRCs *)
-let imported_units() =
- Consistbl.extract crc_units
+let imports() =
+ Consistbl.extract !imported_units crc_units
(* Save a signature to a file *)
@@ -1596,20 +1615,21 @@ let save_signature_with_imports sg modname filename imports =
{ ps_name = modname;
ps_sig = sg;
ps_comps = comps;
- ps_crcs = (cmi.cmi_name, crc) :: imports;
+ ps_crcs = (cmi.cmi_name, Some crc) :: imports;
ps_filename = filename;
ps_flags = cmi.cmi_flags;
ps_crcs_checked = true } in
Hashtbl.add persistent_structures modname (Some ps);
Consistbl.set crc_units modname crc filename;
+ imported_units := modname :: !imported_units;
sg
with exn ->
close_out oc;
remove_file filename;
raise exn
let save_signature sg modname filename =
- save_signature_with_imports sg modname filename (imported_units())
+ save_signature_with_imports sg modname filename (imports())
(* Folding on environments *)
View
5 typing/env.mli
@@ -153,7 +153,7 @@ val read_signature: string -> string -> signature
val save_signature: signature -> string -> string -> signature
(* Arguments: signature, module name, file name. *)
val save_signature_with_imports:
- signature -> string -> string -> (string * Digest.t) list -> signature
+ signature -> string -> string -> (string * Digest.t option) list -> signature
(* Arguments: signature, module name, file name,
imported units with their CRCs. *)
@@ -163,11 +163,12 @@ val crc_of_unit: string -> Digest.t
(* Return the set of compilation units imported, with their CRC *)
-val imported_units: unit -> (string * Digest.t) list
+val imports: unit -> (string * Digest.t option) list
(* Direct access to the table of imported compilation units with their CRC *)
val crc_units: Consistbl.t
+val imported_units: string list ref
(* Summaries -- compact representation of an environment, to be
exported in debugging information. *)
View
2 typing/typemod.ml
@@ -1637,7 +1637,7 @@ let package_units initial_env objfiles cmifile modulename =
let imports =
List.filter
(fun (name, crc) -> not (List.mem name unit_names))
- (Env.imported_units()) in
+ (Env.imports()) in
(* Write packaged signature *)
if not !Clflags.dont_write_files then begin
let sg =
View
14 utils/config.mlp
@@ -49,15 +49,15 @@ let mkexe = "%%MKEXE%%"
let mkmaindll = "%%MKMAINDLL%%"
let exec_magic_number = "Caml1999X011"
-and cmi_magic_number = "Caml1999I016"
-and cmo_magic_number = "Caml1999O009"
-and cma_magic_number = "Caml1999A010"
-and cmx_magic_number = "Caml1999Y013"
-and cmxa_magic_number = "Caml1999Z012"
+and cmi_magic_number = "Caml1999I017"
+and cmo_magic_number = "Caml1999O010"
+and cma_magic_number = "Caml1999A011"
+and cmx_magic_number = "Caml1999Y014"
+and cmxa_magic_number = "Caml1999Z013"
and ast_impl_magic_number = "Caml1999M016"
and ast_intf_magic_number = "Caml1999N015"
-and cmxs_magic_number = "Caml2007D001"
-and cmt_magic_number = "Caml2012T003"
+and cmxs_magic_number = "Caml2007D002"
+and cmt_magic_number = "Caml2012T004"
let load_path = ref ([] : string list)
View
15 utils/consistbl.ml
@@ -40,8 +40,19 @@ let set tbl name crc source = Hashtbl.add tbl name (crc, source)
let source tbl name = snd (Hashtbl.find tbl name)
-let extract tbl =
- Hashtbl.fold (fun name (crc, auth) accu -> (name, crc) :: accu) tbl []
+let extract l tbl =
+ List.fold_left
+ (fun assc name ->
+ try
+ ignore (List.assoc name assc);
+ assc
+ with Not_found ->
+ try
+ let (crc, _) = Hashtbl.find tbl name in
+ (name, Some crc) :: assc
+ with Not_found ->
+ (name, None) :: assc)
+ [] l
let filter p tbl =
let to_remove = ref [] in
View
7 utils/consistbl.mli
@@ -40,9 +40,10 @@ val source: t -> string -> string
if the latter has an associated CRC in [tbl].
Raise [Not_found] otherwise. *)
-val extract: t -> (string * Digest.t) list
- (* Return all bindings ([name], [crc]) contained in the given
- table. *)
+val extract: string list -> t -> (string * Digest.t option) list
+ (* [extract tbl names] returns an associative list mapping each string
+ in [names] to the CRC associated with it in [tbl]. If no CRC is
+ associated with a name then it is mapped to [None]. *)
val filter: (string -> bool) -> t -> unit
(* [filter pred tbl] removes from [tbl] table all (name, CRC) pairs

0 comments on commit 521ac02

Please sign in to comment.