Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

revert commit 14719 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14723 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Jacques Garrigue 2014-05-02 06:19:55 +00:00
parent 9baf42b72d
commit 95104b3924
36 changed files with 130 additions and 214 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
asmcomp/asmlink.ml
View File

@ -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));

4
asmcomp/asmlink.mli
View File

@ -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

2
asmcomp/asmpackager.ml
View File

@ -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());

9
asmcomp/cmx_format.mli
View File

@ -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;
}

9
asmcomp/compilenv.ml
View File

@ -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

4
asmcomp/compilenv.mli
View File

@ -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 =

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamldep
View File

Binary file not shown.

BIN
boot/ocamllex
View File

Binary file not shown.

23
bytecomp/bytelink.ml
View File

@ -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;

2
bytecomp/bytelink.mli
View File

@ -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

3
bytecomp/bytepackager.ml
View File

@ -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;

3
bytecomp/cmo_format.mli
View File

@ -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 *)

2
bytecomp/emitcode.ml
View File

@ -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;

2
bytecomp/symtable.ml
View File

@ -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();

2
bytecomp/symtable.mli
View File

@ -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

2
driver/main_args.ml
View File

@ -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,

3
man/ocamlc.m
View File

@ -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]

3
man/ocamlopt.m
View File

@ -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]

31
otherlibs/dynlink/dynlink.ml
View File

@ -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

51
otherlibs/dynlink/natdynlink.ml
View File

@ -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

13
tools/objinfo.ml
View File

@ -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"

11
tools/read_cmt.ml
View File

@ -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 "%!";
()

2
toplevel/expunge.ml
View File

@ -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

7
toplevel/topdirs.ml
View File

@ -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@ \

8
toplevel/toploop.ml
View File

@ -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 =

4
typing/cmi_format.ml
View File

@ -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

2
typing/cmi_format.mli
View File

@ -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;
}

4
typing/cmt_format.ml
View File

@ -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

2
typing/cmt_format.mli
View File

@ -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;
}

42
typing/env.ml
View File

@ -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 *)

5
typing/env.mli
View File

@ -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. *)

2
typing/typemod.ml
View File

@ -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 =

14
utils/config.mlp
View File

@ -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)

15
utils/consistbl.ml
View File

@ -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

7
utils/consistbl.mli
View File

@ -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