diff options
36 files changed, 130 insertions, 214 deletions
diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index 4c589904b..5842f44eb 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -33,37 +33,31 @@ 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 implementations = ref ([] : string list) +let extra_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, 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) + (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) unit.ui_imports_cmi with Consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_interface(name, user, auth))) end; begin try List.iter - (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) + (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) unit.ui_imports_cmx with Consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_implementation(name, user, auth))) @@ -73,7 +67,6 @@ 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; @@ -81,9 +74,13 @@ let check_consistency file_name unit crc = cmx_required := unit.ui_name :: !cmx_required let extract_crc_interfaces () = - Consistbl.extract !interfaces crc_interfaces + Consistbl.extract crc_interfaces let extract_crc_implementations () = - Consistbl.extract !implementations 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 (* Add C objects and options and "custom" info from a library descriptor. See bytecomp/bytelink.ml for comments on the order of C objects. *) @@ -217,14 +214,10 @@ let make_startup_file ppf filename units_list = (Cmmgen.globals_map (List.map (fun (unit,_,crc) -> - 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)) + try (unit.ui_name, List.assoc unit.ui_name unit.ui_imports_cmi, + crc, + unit.ui_defines) + with Not_found -> assert false) 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 3b1428cdf..1cf9e302c 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 option) list -val extract_crc_implementations: unit -> (string * Digest.t option) list +val extract_crc_interfaces: unit -> (string * Digest.t) list +val extract_crc_implementations: unit -> (string * Digest.t) list type error = File_not_found of string diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index d900df1e1..63ed21c89 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, Some (Env.crc_of_unit ui.ui_name)) :: + (ui.ui_name, 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 51aa04408..c4e557969 100644 --- a/asmcomp/cmx_format.mli +++ b/asmcomp/cmx_format.mli @@ -26,9 +26,8 @@ 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 option) list; (* Interfaces imported *) - mutable ui_imports_cmx:(string * Digest.t option) list; (* Infos imported *) + mutable ui_imports_cmi: (string * Digest.t) list; (* Interfaces imported *) + mutable ui_imports_cmx: (string * Digest.t) 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 *) @@ -50,8 +49,8 @@ type library_infos = type dynunit = { dynu_name: string; dynu_crc: Digest.t; - dynu_imports_cmi: (string * Digest.t option) list; - dynu_imports_cmx: (string * Digest.t option) list; + dynu_imports_cmi: (string * Digest.t) list; + dynu_imports_cmx: (string * Digest.t) list; dynu_defines: string list; } diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml index e0599d405..c7bbdb531 100644 --- a/asmcomp/compilenv.ml +++ b/asmcomp/compilenv.ml @@ -143,6 +143,9 @@ 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 @@ -158,9 +161,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, Some crc) + (Some ui, crc) with Not_found -> - (None, None) in + (None, cmx_not_found_crc) in current_unit.ui_imports_cmx <- (modname, crc) :: current_unit.ui_imports_cmx; Hashtbl.add global_infos_table modname infos; @@ -228,7 +231,7 @@ let write_unit_info info filename = close_out oc let save_unit_info filename = - current_unit.ui_imports_cmi <- Env.imports(); + current_unit.ui_imports_cmi <- Env.imported_units(); write_unit_info current_unit filename diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli index 7fae3bade..b705f4496 100644 --- a/asmcomp/compilenv.mli +++ b/asmcomp/compilenv.mli @@ -79,6 +79,10 @@ 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 60f5169d1..54509de1d 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex ea6a9dd9b..6fe1ad368 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex bc6a0f2cd..69fbe9ee6 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index 76a7453f1..d3410fa1e 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -158,20 +158,15 @@ 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, 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) + (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) cu.cu_imports with Consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_import(name, user, auth))) @@ -188,11 +183,7 @@ let check_consistency ppf file_name cu = (cu.cu_name, file_name) :: !implementations_defined let extract_crc_interfaces () = - Consistbl.extract !interfaces crc_interfaces - -let clear_crc_interfaces () = - Consistbl.clear crc_interfaces; - interfaces := [] + Consistbl.extract crc_interfaces (* Record compilation events *) @@ -316,7 +307,7 @@ let link_bytecode ppf tolink exec_name standalone = (* The bytecode *) let start_code = pos_out outchan in Symtable.init(); - clear_crc_interfaces (); + Consistbl.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 @@ -449,7 +440,7 @@ let link_bytecode_as_c ppf tolink outfile = \n char **argv);\n"; output_string outchan "static int caml_code[] = {\n"; Symtable.init(); - clear_crc_interfaces (); + Consistbl.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 324d02e1f..6e123c3f5 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 option) list +val extract_crc_interfaces: unit -> (string * Digest.t) list type error = File_not_found of string diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index fcef71c8d..0ec05244b 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -235,8 +235,7 @@ 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, Some (Env.crc_of_unit targetname)) :: imports; + cu_imports = (targetname, 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 0c0f08f08..abf4f1af3 100644 --- a/bytecomp/cmo_format.mli +++ b/bytecomp/cmo_format.mli @@ -27,8 +27,7 @@ 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 option) list; (* Names and CRC of intfs imported *) + cu_imports: (string * Digest.t) 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 8adcf1592..17c09f44c 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.imports(); + cu_imports = Env.imported_units(); 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 31c958bdb..788c0e69d 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 option) list) + try (Obj.magic (sect.read_struct "CRCS") : (string * Digest.t) list) with Not_found -> [] in (* Done *) sect.close_reader(); diff --git a/bytecomp/symtable.mli b/bytecomp/symtable.mli index 71aecf914..82df2cd8a 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 option) list +val init_toplevel: unit -> (string * Digest.t) 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/driver/main_args.ml b/driver/main_args.ml index 7c04d25be..1444ae457 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -275,7 +275,7 @@ let mk_thread f = let mk_trans_mod f = "-trans-mod", Arg.Unit f, - " Do not import unused module aliases" + " Make typing and linking only depend on normalized paths" let mk_unsafe f = "-unsafe", Arg.Unit f, diff --git a/man/ocamlc.m b/man/ocamlc.m index 37002ecda..6c6174a77 100644 --- a/man/ocamlc.m +++ b/man/ocamlc.m @@ -538,9 +538,6 @@ Compile or link multithreaded programs, in combination with the 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] diff --git a/man/ocamlopt.m b/man/ocamlopt.m index 4e9decf4d..e951b77f8 100644 --- a/man/ocamlopt.m +++ b/man/ocamlopt.m @@ -512,9 +512,6 @@ Compile or link multithreaded programs, in combination with the 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] diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml index 47409ad36..15febc3c8 100644 --- a/otherlibs/dynlink/dynlink.ml +++ b/otherlibs/dynlink/dynlink.ml @@ -79,16 +79,13 @@ let allow_extension = ref true let check_consistency file_name cu = try List.iter - (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) + (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) cu.cu_imports with Consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_import name)) @@ -116,21 +113,15 @@ 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(); - List.iter - (fun (unit, crco) -> - match crco with - None -> () - | Some crc -> Consistbl.set !crc_interfaces unit crc "") - !default_crcs; + add_available_units !default_crcs; allow_extension := true (* Initialize the linker tables and everything *) @@ -172,7 +163,7 @@ let digest_interface unit loadpath = close_in ic; let crc = match cmi.Cmi_format.cmi_crcs with - (_, Some crc) :: _ -> crc + (_, crc) :: _ -> crc | _ -> raise(Error(Corrupted_interface filename)) in crc diff --git a/otherlibs/dynlink/natdynlink.ml b/otherlibs/dynlink/natdynlink.ml index 597d60fb5..0ae24fa68 100644 --- a/otherlibs/dynlink/natdynlink.ml +++ b/otherlibs/dynlink/natdynlink.ml @@ -41,7 +41,11 @@ exception Error of error open Cmx_format (* Copied from config.ml to avoid dependencies *) -let cmxs_magic_number = "Caml2007D002" +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 dll_filename fname = if Filename.is_implicit fname then Filename.concat (Sys.getcwd ()) fname @@ -110,26 +114,23 @@ let init () = let add_check_ifaces allow_ext filename ui ifaces = List.fold_left - (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)) + (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)) ) ifaces ui.dynu_imports_cmi let check_implems filename ui implems = List.iter - (fun (name, crco) -> + (fun (name, crc) -> match name with |"Out_of_memory" |"Sys_error" @@ -146,15 +147,13 @@ let check_implems filename ui implems = | _ -> try let (old_crc,old_src,state) = StrMap.find name implems in - 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 -> () + 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 -> () with Not_found -> raise (Error(Unavailable_unit name)) ) ui.dynu_imports_cmx diff --git a/tools/objinfo.ml b/tools/objinfo.ml index 3eaafcca7..0eb33882a 100644 --- a/tools/objinfo.ml +++ b/tools/objinfo.ml @@ -34,15 +34,8 @@ let input_stringlist ic len = let sect = really_input_string ic len in get_string_list sect len -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_name_crc (name, crc) = + printf "\t%s\t%s\n" (Digest.to_hex crc) name let print_line name = printf "\t%s\n" name @@ -150,7 +143,7 @@ let dump_byte ic = | "CRCS" -> p_section "Imported units" - (input_value ic : (string * Digest.t option) list) + (input_value ic : (string * Digest.t) list) | "DLLS" -> p_list "Used DLLs" diff --git a/tools/read_cmt.ml b/tools/read_cmt.ml index eacba02a5..0ff9f3df7 100644 --- a/tools/read_cmt.ml +++ b/tools/read_cmt.ml @@ -27,8 +27,6 @@ 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; @@ -62,13 +60,8 @@ let print_info cmt = | Some digest -> Printf.printf "interface digest: %s\n" (Digest.to_hex digest); end; - 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.iter (fun (name, digest) -> + Printf.printf "import: %s %s\n" name (Digest.to_hex digest); ) (List.sort compare cmt.cmt_imports); Printf.printf "%!"; () diff --git a/toplevel/expunge.ml b/toplevel/expunge.ml index a893c60dd..fa6fd7ca5 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 option) list) in + let crcs = (input_value ic : (string * Digest.t) 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 d4447308a..f9d383380 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -61,12 +61,7 @@ exception Load_failed let check_consistency ppf filename cu = try List.iter - (fun (name, crco) -> - Env.imported_units := name :: !Env.imported_units; - match crco with - None -> () - | Some crc-> - Consistbl.check Env.crc_units name crc filename) + (fun (name, 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 ea30bf52e..e991ee649 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -424,12 +424,8 @@ let _ = let crc_intfs = Symtable.init_toplevel() in Compmisc.init_path false; List.iter - (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) + (fun (name, 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 6f421fdcf..00358b66a 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 option) list; + cmi_crcs : (string * Digest.t) 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, Some crc) :: cmi.cmi_crcs in + let crcs = (cmi.cmi_name, 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 32cec451f..2d6fdec6b 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 option) list; + cmi_crcs : (string * Digest.t) list; cmi_flags : pers_flags list; } diff --git a/typing/cmt_format.ml b/typing/cmt_format.ml index 6cecb1b69..f07e44256 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 option) list; + cmt_imports : (string * Digest.t) 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.imports () in + let imports = Env.imported_units () 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 48fbc639e..ba264a314 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 option) list; + cmt_imports : (string * Digest.t) list; cmt_interface_digest : Digest.t option; cmt_use_summaries : bool; } diff --git a/typing/env.ml b/typing/env.ml index 57b4369a0..7e904fc9f 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 option) list; + ps_crcs: (string * Digest.t) list; ps_filename: string; ps_flags: pers_flags list; mutable ps_crcs_checked: bool } @@ -297,25 +297,12 @@ 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, crco) -> - match crco with - None -> () - | Some crc -> Consistbl.check crc_units name crc ps.ps_filename) + (fun (name, crc) -> Consistbl.check crc_units name crc ps.ps_filename) ps.ps_crcs; ps.ps_crcs_checked <- true with Consistbl.Inconsistency(name, source, auth) -> @@ -343,7 +330,6 @@ 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 -> @@ -378,7 +364,7 @@ let find_pers_struct ?(check=true) name = let reset_cache () = current_unit := ""; Hashtbl.clear persistent_structures; - clear_imports (); + Consistbl.clear crc_units; Hashtbl.clear value_declarations; Hashtbl.clear type_declarations; Hashtbl.clear used_constructors; @@ -1573,20 +1559,15 @@ let read_signature modname filename = let crc_of_unit name = let ps = find_pers_struct ~check:false name in - let crco = - try - List.assoc name ps.ps_crcs - with Not_found -> - assert false - in - match crco with - None -> assert false - | Some crc -> crc + try + List.assoc name ps.ps_crcs + with Not_found -> + assert false (* Return the list of imported interfaces with their CRCs *) -let imports() = - Consistbl.extract !imported_units crc_units +let imported_units() = + Consistbl.extract crc_units (* Save a signature to a file *) @@ -1615,13 +1596,12 @@ let save_signature_with_imports sg modname filename imports = { ps_name = modname; ps_sig = sg; ps_comps = comps; - ps_crcs = (cmi.cmi_name, Some crc) :: imports; + ps_crcs = (cmi.cmi_name, 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; @@ -1629,7 +1609,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 (imports()) + save_signature_with_imports sg modname filename (imported_units()) (* Folding on environments *) diff --git a/typing/env.mli b/typing/env.mli index ba5f0dee7..f5ef302b3 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 option) list -> signature + signature -> string -> string -> (string * Digest.t) list -> signature (* Arguments: signature, module name, file name, imported units with their CRCs. *) @@ -163,12 +163,11 @@ val crc_of_unit: string -> Digest.t (* Return the set of compilation units imported, with their CRC *) -val imports: unit -> (string * Digest.t option) list +val imported_units: unit -> (string * Digest.t) 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 35908b22f..51171ff64 100644 --- a/typing/typemod.ml +++ b/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.imports()) in + (Env.imported_units()) 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 db6fd20ed..e4c0d322a 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 = "Caml1999I017" -and cmo_magic_number = "Caml1999O010" -and cma_magic_number = "Caml1999A011" -and cmx_magic_number = "Caml1999Y014" -and cmxa_magic_number = "Caml1999Z013" +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 ast_impl_magic_number = "Caml1999M016" and ast_intf_magic_number = "Caml1999N015" -and cmxs_magic_number = "Caml2007D002" -and cmt_magic_number = "Caml2012T004" +and cmxs_magic_number = "Caml2007D001" +and cmt_magic_number = "Caml2012T003" let load_path = ref ([] : string list) diff --git a/utils/consistbl.ml b/utils/consistbl.ml index 6adaf4112..4bc42dc5b 100644 --- a/utils/consistbl.ml +++ b/utils/consistbl.ml @@ -40,19 +40,8 @@ let set tbl name crc source = Hashtbl.add tbl name (crc, source) let source tbl name = snd (Hashtbl.find tbl name) -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 extract tbl = + Hashtbl.fold (fun name (crc, auth) accu -> (name, crc) :: accu) tbl [] let filter p tbl = let to_remove = ref [] in diff --git a/utils/consistbl.mli b/utils/consistbl.mli index 012bd734f..d3f2afcec 100644 --- a/utils/consistbl.mli +++ b/utils/consistbl.mli @@ -40,10 +40,9 @@ val source: t -> string -> string if the latter has an associated CRC in [tbl]. Raise [Not_found] otherwise. *) -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 extract: t -> (string * Digest.t) list + (* Return all bindings ([name], [crc]) contained in the given + table. *) val filter: (string -> bool) -> t -> unit (* [filter pred tbl] removes from [tbl] table all (name, CRC) pairs |