diff options
35 files changed, 213 insertions, 129 deletions
diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index 5842f44eb..4c589904b 100644 --- a/asmcomp/asmlink.ml +++ b/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,6 +73,7 @@ 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; @@ -74,13 +81,9 @@ let check_consistency file_name unit crc = 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)); diff --git a/asmcomp/asmlink.mli b/asmcomp/asmlink.mli index 1cf9e302c..3b1428cdf 100644 --- a/asmcomp/asmlink.mli +++ b/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 diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index 63ed21c89..d900df1e1 100644 --- a/asmcomp/asmpackager.ml +++ b/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()); diff --git a/asmcomp/cmx_format.mli b/asmcomp/cmx_format.mli index c4e557969..51aa04408 100644 --- a/asmcomp/cmx_format.mli +++ b/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; } diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml index c7bbdb531..e0599d405 100644 --- a/asmcomp/compilenv.ml +++ b/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 diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli index b705f4496..7fae3bade 100644 --- a/asmcomp/compilenv.mli +++ b/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 = diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex 15b453288..de70a3613 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex 957527f56..0efba669b 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 17f17c70a..5f7500150 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index d3410fa1e..76a7453f1 100644 --- a/bytecomp/bytelink.ml +++ b/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; diff --git a/bytecomp/bytelink.mli b/bytecomp/bytelink.mli index 6e123c3f5..324d02e1f 100644 --- a/bytecomp/bytelink.mli +++ b/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 diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index 0ec05244b..fcef71c8d 100644 --- a/bytecomp/bytepackager.ml +++ b/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; diff --git a/bytecomp/cmo_format.mli b/bytecomp/cmo_format.mli index abf4f1af3..0c0f08f08 100644 --- a/bytecomp/cmo_format.mli +++ b/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 *) diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index 17c09f44c..8adcf1592 100644 --- a/bytecomp/emitcode.ml +++ b/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; diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index 788c0e69d..31c958bdb 100644 --- a/bytecomp/symtable.ml +++ b/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(); diff --git a/bytecomp/symtable.mli b/bytecomp/symtable.mli index 82df2cd8a..71aecf914 100644 --- a/bytecomp/symtable.mli +++ b/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 diff --git a/man/ocamlc.m b/man/ocamlc.m index c3f27a12c..7038f8e88 100644 --- a/man/ocamlc.m +++ b/man/ocamlc.m @@ -396,6 +396,9 @@ bytecode executables produced with the option .B ocamlc\ \-use\-runtime .IR runtime-name . .TP +.B \-no-alias-deps +Do not record dependencies for module aliases. +.TP .B \-no\-app\-funct Deactivates the applicative behaviour of functors. With this option, each functor application generates new types in its result and diff --git a/man/ocamlopt.m b/man/ocamlopt.m index e951b77f8..703addc7d 100644 --- a/man/ocamlopt.m +++ b/man/ocamlopt.m @@ -316,6 +316,9 @@ flag forces all subsequent links of programs involving that library to link all the modules contained in the library. .TP +.B \-no-alias-deps +Do not record dependencies for module aliases. +.TP .B \-no\-app\-funct Deactivates the applicative behaviour of functors. With this option, each functor application generates new types in its result and diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml index 15febc3c8..47409ad36 100644 --- a/otherlibs/dynlink/dynlink.ml +++ b/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 diff --git a/otherlibs/dynlink/natdynlink.ml b/otherlibs/dynlink/natdynlink.ml index 0ae24fa68..597d60fb5 100644 --- a/otherlibs/dynlink/natdynlink.ml +++ b/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 diff --git a/tools/objinfo.ml b/tools/objinfo.ml index 0eb33882a..3eaafcca7 100644 --- a/tools/objinfo.ml +++ b/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" diff --git a/tools/read_cmt.ml b/tools/read_cmt.ml index 0ff9f3df7..eacba02a5 100644 --- a/tools/read_cmt.ml +++ b/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 "%!"; () diff --git a/toplevel/expunge.ml b/toplevel/expunge.ml index fa6fd7ca5..a893c60dd 100644 --- a/toplevel/expunge.ml +++ b/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 diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index 57bb3e501..bc12a6312 100644 --- a/toplevel/topdirs.ml +++ b/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@ \ diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index 6c7857aaa..152f114f8 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -425,8 +425,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 = diff --git a/typing/cmi_format.ml b/typing/cmi_format.ml index 00358b66a..6f421fdcf 100644 --- a/typing/cmi_format.ml +++ b/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 diff --git a/typing/cmi_format.mli b/typing/cmi_format.mli index 2d6fdec6b..32cec451f 100644 --- a/typing/cmi_format.mli +++ b/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; } diff --git a/typing/cmt_format.ml b/typing/cmt_format.ml index f07e44256..6cecb1b69 100644 --- a/typing/cmt_format.ml +++ b/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 diff --git a/typing/cmt_format.mli b/typing/cmt_format.mli index ba264a314..48fbc639e 100644 --- a/typing/cmt_format.mli +++ b/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; } diff --git a/typing/env.ml b/typing/env.ml index 247e060f2..f7ef02d22 100644 --- a/typing/env.ml +++ b/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; @@ -1564,15 +1578,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 *) @@ -1601,12 +1620,13 @@ 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; @@ -1614,7 +1634,7 @@ let save_signature_with_imports sg modname filename imports = 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 *) diff --git a/typing/env.mli b/typing/env.mli index d346d0104..36e1b0021 100644 --- a/typing/env.mli +++ b/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. *) diff --git a/typing/typemod.ml b/typing/typemod.ml index 738c9bc4e..5d4cdb9a8 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -1669,7 +1669,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 = diff --git a/utils/config.mlp b/utils/config.mlp index e4c0d322a..db6fd20ed 100644 --- a/utils/config.mlp +++ b/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) diff --git a/utils/consistbl.ml b/utils/consistbl.ml index 4bc42dc5b..6adaf4112 100644 --- a/utils/consistbl.ml +++ b/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 diff --git a/utils/consistbl.mli b/utils/consistbl.mli index d3f2afcec..012bd734f 100644 --- a/utils/consistbl.mli +++ b/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 |