diff --git a/.depend b/.depend index 5e8043764541..9736dee75fd2 100644 --- a/.depend +++ b/.depend @@ -105,6 +105,16 @@ utils/identifiable.cmx : \ utils/misc.cmx \ utils/identifiable.cmi utils/identifiable.cmi : +utils/import_info.cmo : \ + utils/misc.cmi \ + utils/compilation_unit.cmi \ + utils/import_info.cmi +utils/import_info.cmx : \ + utils/misc.cmx \ + utils/compilation_unit.cmx \ + utils/import_info.cmi +utils/import_info.cmi : \ + utils/compilation_unit.cmi utils/int_replace_polymorphic_compare.cmo : \ utils/int_replace_polymorphic_compare.cmi utils/int_replace_polymorphic_compare.cmx : \ @@ -720,6 +730,7 @@ typing/env.cmi : \ parsing/longident.cmi \ parsing/location.cmi \ utils/load_path.cmi \ + utils/import_info.cmi \ typing/ident.cmi \ utils/compilation_unit.cmi \ file_formats/cmi_format.cmi \ @@ -1071,6 +1082,7 @@ typing/persistent_env.cmo : \ parsing/location.cmi \ utils/load_path.cmi \ utils/lazy_backtrack.cmi \ + utils/import_info.cmi \ utils/consistbl.cmi \ utils/config.cmi \ utils/compilation_unit.cmi \ @@ -1083,6 +1095,7 @@ typing/persistent_env.cmx : \ parsing/location.cmx \ utils/load_path.cmx \ utils/lazy_backtrack.cmx \ + utils/import_info.cmx \ utils/consistbl.cmx \ utils/config.cmx \ utils/compilation_unit.cmx \ @@ -1094,6 +1107,7 @@ typing/persistent_env.cmi : \ utils/misc.cmi \ parsing/location.cmi \ utils/lazy_backtrack.cmi \ + utils/import_info.cmi \ utils/consistbl.cmi \ utils/compilation_unit.cmi \ file_formats/cmi_format.cmi @@ -1786,6 +1800,7 @@ typing/typemod.cmo : \ utils/load_path.cmi \ typing/includemod_errorprinter.cmi \ typing/includemod.cmi \ + utils/import_info.cmi \ typing/ident.cmi \ typing/envaux.cmi \ typing/env.cmi \ @@ -1823,6 +1838,7 @@ typing/typemod.cmx : \ utils/load_path.cmx \ typing/includemod_errorprinter.cmx \ typing/includemod.cmx \ + utils/import_info.cmx \ typing/ident.cmx \ typing/envaux.cmx \ typing/env.cmx \ @@ -2080,6 +2096,7 @@ bytecomp/bytelink.cmo : \ parsing/location.cmi \ utils/load_path.cmi \ bytecomp/instruct.cmi \ + utils/import_info.cmi \ typing/ident.cmi \ bytecomp/emitcode.cmi \ bytecomp/dll.cmi \ @@ -2099,6 +2116,7 @@ bytecomp/bytelink.cmx : \ parsing/location.cmx \ utils/load_path.cmx \ bytecomp/instruct.cmx \ + utils/import_info.cmx \ typing/ident.cmx \ bytecomp/emitcode.cmx \ bytecomp/dll.cmx \ @@ -2113,6 +2131,7 @@ bytecomp/bytelink.cmx : \ bytecomp/bytelink.cmi : \ bytecomp/symtable.cmi \ utils/misc.cmi \ + utils/import_info.cmi \ utils/compilation_unit.cmi \ file_formats/cmo_format.cmi bytecomp/bytepackager.cmo : \ @@ -2126,6 +2145,7 @@ bytecomp/bytepackager.cmo : \ parsing/location.cmi \ utils/load_path.cmi \ bytecomp/instruct.cmi \ + utils/import_info.cmi \ typing/ident.cmi \ typing/env.cmi \ bytecomp/emitcode.cmi \ @@ -2147,6 +2167,7 @@ bytecomp/bytepackager.cmx : \ parsing/location.cmx \ utils/load_path.cmx \ bytecomp/instruct.cmx \ + utils/import_info.cmx \ typing/ident.cmx \ typing/env.cmx \ bytecomp/emitcode.cmx \ @@ -2286,6 +2307,7 @@ bytecomp/symtable.cmo : \ bytecomp/meta.cmi \ parsing/location.cmi \ lambda/lambda.cmi \ + utils/import_info.cmi \ typing/ident.cmi \ bytecomp/dll.cmi \ utils/config.cmi \ @@ -2301,6 +2323,7 @@ bytecomp/symtable.cmx : \ bytecomp/meta.cmx \ parsing/location.cmx \ lambda/lambda.cmx \ + utils/import_info.cmx \ typing/ident.cmx \ bytecomp/dll.cmx \ utils/config.cmx \ @@ -2312,6 +2335,7 @@ bytecomp/symtable.cmx : \ bytecomp/symtable.cmi : \ utils/misc.cmi \ lambda/lambda.cmi \ + utils/import_info.cmi \ typing/ident.cmi \ file_formats/cmo_format.cmi asmcomp/CSE.cmo : \ @@ -2487,6 +2511,7 @@ asmcomp/asmlink.cmo : \ utils/misc.cmi \ parsing/location.cmi \ utils/load_path.cmi \ + utils/import_info.cmi \ asmcomp/emitaux.cmi \ asmcomp/emit.cmi \ utils/consistbl.cmi \ @@ -2507,6 +2532,7 @@ asmcomp/asmlink.cmx : \ utils/misc.cmx \ parsing/location.cmx \ utils/load_path.cmx \ + utils/import_info.cmx \ asmcomp/emitaux.cmx \ asmcomp/emit.cmx \ utils/consistbl.cmx \ @@ -2522,6 +2548,7 @@ asmcomp/asmlink.cmx : \ asmcomp/asmlink.cmi asmcomp/asmlink.cmi : \ utils/misc.cmi \ + utils/import_info.cmi \ utils/compilation_unit.cmi \ file_formats/cmx_format.cmi asmcomp/asmpackager.cmo : \ @@ -2535,6 +2562,7 @@ asmcomp/asmpackager.cmo : \ utils/load_path.cmi \ utils/linkage_name.cmi \ lambda/lambda.cmi \ + utils/import_info.cmi \ middle_end/flambda/flambda_middle_end.cmi \ middle_end/flambda/export_info.cmi \ typing/env.cmi \ @@ -2559,6 +2587,7 @@ asmcomp/asmpackager.cmx : \ utils/load_path.cmx \ utils/linkage_name.cmx \ lambda/lambda.cmx \ + utils/import_info.cmx \ middle_end/flambda/flambda_middle_end.cmx \ middle_end/flambda/export_info.cmx \ typing/env.cmx \ @@ -3421,6 +3450,7 @@ middle_end/compilenv.cmo : \ parsing/location.cmi \ utils/load_path.cmi \ utils/linkage_name.cmi \ + utils/import_info.cmi \ typing/ident.cmi \ middle_end/flambda/export_info.cmi \ typing/env.cmi \ @@ -3440,6 +3470,7 @@ middle_end/compilenv.cmx : \ parsing/location.cmx \ utils/load_path.cmx \ utils/linkage_name.cmx \ + utils/import_info.cmx \ typing/ident.cmx \ middle_end/flambda/export_info.cmx \ typing/env.cmx \ @@ -4050,6 +4081,7 @@ file_formats/cmi_format.cmo : \ typing/types.cmi \ utils/misc.cmi \ parsing/location.cmi \ + utils/import_info.cmi \ utils/config.cmi \ utils/compilation_unit.cmi \ file_formats/cmi_format.cmi @@ -4057,15 +4089,18 @@ file_formats/cmi_format.cmx : \ typing/types.cmx \ utils/misc.cmx \ parsing/location.cmx \ + utils/import_info.cmx \ utils/config.cmx \ utils/compilation_unit.cmx \ file_formats/cmi_format.cmi file_formats/cmi_format.cmi : \ typing/types.cmi \ utils/misc.cmi \ + utils/import_info.cmi \ utils/compilation_unit.cmi file_formats/cmo_format.cmi : \ lambda/lambda.cmi \ + utils/import_info.cmi \ typing/ident.cmi \ utils/compilation_unit.cmi file_formats/cmt_format.cmo : \ @@ -4077,6 +4112,7 @@ file_formats/cmt_format.cmo : \ parsing/location.cmi \ utils/load_path.cmi \ parsing/lexer.cmi \ + utils/import_info.cmi \ typing/env.cmi \ utils/config.cmi \ utils/compilation_unit.cmi \ @@ -4092,6 +4128,7 @@ file_formats/cmt_format.cmx : \ parsing/location.cmx \ utils/load_path.cmx \ parsing/lexer.cmx \ + utils/import_info.cmx \ typing/env.cmx \ utils/config.cmx \ utils/compilation_unit.cmx \ @@ -4108,6 +4145,7 @@ file_formats/cmt_format.cmi : \ file_formats/cmi_format.cmi file_formats/cmx_format.cmi : \ lambda/lambda.cmi \ + utils/import_info.cmi \ middle_end/flambda/export_info.cmi \ utils/compilation_unit.cmi \ middle_end/clambda.cmi @@ -6427,17 +6465,17 @@ toplevel/expunge.cmo : \ bytecomp/symtable.cmi \ lambda/runtimedef.cmi \ utils/misc.cmi \ + utils/import_info.cmi \ typing/ident.cmi \ utils/compilation_unit.cmi \ - file_formats/cmo_format.cmi \ bytecomp/bytesections.cmi toplevel/expunge.cmx : \ bytecomp/symtable.cmx \ lambda/runtimedef.cmx \ utils/misc.cmx \ + utils/import_info.cmx \ typing/ident.cmx \ utils/compilation_unit.cmx \ - file_formats/cmo_format.cmi \ bytecomp/bytesections.cmx toplevel/genprintval.cmo : \ typing/types.cmi \ diff --git a/HACKING.jst.adoc b/HACKING.jst.adoc index 1c9511198822..2d64fb752fe5 100644 --- a/HACKING.jst.adoc +++ b/HACKING.jst.adoc @@ -2,9 +2,9 @@ ocaml-jst has a dune-based build system which is different from upstream OCaml. To get started, you'll need a working install of OCaml -4.12 and dune, e.g. via OPAM: +4.14 and dune, e.g. via OPAM: - $ opam switch create 4.12.0 + $ opam switch create 4.14.0 $ eval $(opam env) $ opam install dune @@ -30,7 +30,7 @@ to build without running the testsuite, or: to start a continuously polling build of the compiler. Note that the dune-based build system is entirely separate from the main -Makefile, and so you will need to use `make -f Makefile.jst install` +Makefile, and so you will need to use `make -f Makefile.jst install` to install after building. ## Testing diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index 4db3a0d6bf27..db0a705ebe0a 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -49,8 +49,10 @@ let cmx_required = ref ([] : CU.t list) let check_consistency file_name unit crc = begin try - List.iter - (fun (name, crco) -> + Array.iter + (fun import -> + let name = Import_info.name import in + let crco = Import_info.crc_with_unit import in interfaces := name :: !interfaces; match crco with None -> () @@ -68,8 +70,10 @@ let check_consistency file_name unit crc = raise(Error(Inconsistent_interface(name, user, auth))) end; begin try - List.iter - (fun (name, crco) -> + Array.iter + (fun import -> + let name = Import_info.cu import in + let crco = Import_info.crc import in implementations := name :: !implementations; match crco with None -> @@ -100,9 +104,15 @@ let check_consistency file_name unit crc = let extract_crc_interfaces () = Cmi_consistbl.extract !interfaces crc_interfaces + |> List.map (fun (name, crc_with_unit) -> + Import_info.create name ~crc_with_unit) + let extract_crc_implementations () = Cmx_consistbl.extract !implementations crc_implementations - |> List.map (fun (name, crco) -> name, Option.map snd crco) + |> List.map (fun (cu, crc) -> + let crc = Option.map (fun ((), crc) -> crc) crc in + Import_info.create_normal cu ~crc) + (* Add C objects and options and "custom" info from a library descriptor. See bytecomp/bytelink.ml for comments on the order of C objects. *) @@ -137,7 +147,8 @@ let is_required name = try ignore (Hashtbl.find missing_globals name); true with Not_found -> false -let add_required by (name, _crc) = +let add_required by import = + let name = Import_info.cu import in try let rq = Hashtbl.find missing_globals name in rq := by :: !rq @@ -199,7 +210,7 @@ let scan_file file tolink = | Unit (file_name,info,crc) -> (* This is a .cmx file. It must be linked in any case. *) remove_required info.ui_unit; - List.iter (add_required file_name) info.ui_imports_cmx; + Array.iter (add_required file_name) info.ui_imports_cmx; (info, file_name, crc) :: tolink | Library (file_name,infos) -> (* This is an archive file. Each unit contained in it will be linked @@ -216,7 +227,7 @@ let scan_file file tolink = let req_by = Printf.sprintf "%s(%s)" file_name (ui_name |> CU.Name.to_string) in - List.iter (add_required req_by) info.ui_imports_cmx; + Array.iter (add_required req_by) info.ui_imports_cmx; (info, file_name, crc) :: reqd end else reqd) @@ -231,6 +242,8 @@ let force_linking_of_startup ~ppf_dump = let make_globals_map units_list ~crc_interfaces = let crc_interfaces = crc_interfaces + |> List.map (fun import -> + Import_info.name import, Import_info.crc_with_unit import) |> CU.Name.Tbl.of_list in let defined = diff --git a/asmcomp/asmlink.mli b/asmcomp/asmlink.mli index 2338442bef59..c243378e9e33 100644 --- a/asmcomp/asmlink.mli +++ b/asmcomp/asmlink.mli @@ -26,8 +26,8 @@ val call_linker_shared: string list -> string -> unit val reset : unit -> unit val check_consistency: filepath -> Cmx_format.unit_infos -> Digest.t -> unit -val extract_crc_interfaces: unit -> Cmx_format.import_info_cmi list -val extract_crc_implementations: unit -> Cmx_format.import_info_cmx list +val extract_crc_interfaces: unit -> Import_info.t list +val extract_crc_implementations: unit -> Import_info.t list type error = | File_not_found of filepath diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index 95cb25c39c61..60d3ab4479f8 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -70,8 +70,9 @@ let check_units members = begin match mb.pm_kind with | PM_intf -> () | PM_impl infos -> - List.iter - (fun (unit, _) -> + Array.iter + (fun import -> + let unit = Import_info.cu import in let name = CU.name unit in if List.mem name forbidden then raise(Error(Forward_reference(mb.pm_file, name)))) @@ -174,9 +175,9 @@ let get_approx ui = let build_package_cmx members cmxfile = let unit_names = List.map (fun m -> m.pm_name) members in - let filter ~get_name lst = - List.filter (fun (name, _crc) -> - not (List.mem (get_name name) unit_names)) lst in + let filter lst = + List.filter (fun import -> + not (List.mem (Import_info.name import) unit_names)) lst in let union lst = List.fold_left (List.fold_left @@ -207,10 +208,13 @@ let build_package_cmx members cmxfile = List.flatten (List.map (fun info -> info.ui_defines) units) @ [ui.ui_unit]; ui_imports_cmi = - (modname, Some (ui.ui_unit, Env.crc_of_unit modname)) :: - filter(Asmlink.extract_crc_interfaces()) ~get_name:(fun name -> name); + (Import_info.create modname + ~crc_with_unit:(Some (ui.ui_unit, Env.crc_of_unit modname))) :: + filter (Asmlink.extract_crc_interfaces ()) + |> Array.of_list; ui_imports_cmx = - filter(Asmlink.extract_crc_implementations()) ~get_name:CU.name; + (filter(Asmlink.extract_crc_implementations())) + |> Array.of_list; ui_curry_fun = union(List.map (fun info -> info.ui_curry_fun) units); ui_apply_fun = diff --git a/boot/ocamlc b/boot/ocamlc index 7258f66b3423..e1a26ad76240 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamllex b/boot/ocamllex index 8aade94241ab..8e766686c96b 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index 275f9f398aa5..b56ef425e62d 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -182,8 +182,10 @@ let implementations_defined = ref ([] : (CU.Name.t * string) list) let check_consistency file_name cu = begin try - List.iter - (fun (name, crco) -> + Array.iter + (fun import -> + let name = Import_info.name import in + let crco = Import_info.crc_with_unit import in interfaces := name :: !interfaces; match crco with None -> () @@ -212,6 +214,8 @@ let check_consistency file_name cu = let extract_crc_interfaces () = Consistbl.extract !interfaces crc_interfaces + |> List.map (fun (name, crc_with_unit) -> + Import_info.create name ~crc_with_unit) let clear_crc_interfaces () = Consistbl.clear crc_interfaces; @@ -403,7 +407,7 @@ let link_bytecode ?final_name tolink exec_name standalone = Symtable.output_global_map outchan; Bytesections.record outchan "SYMB"; (* CRCs for modules *) - output_value outchan (extract_crc_interfaces()); + output_value outchan ((extract_crc_interfaces() |> Array.of_list)); Bytesections.record outchan "CRCS"; (* Debug info *) if !Clflags.debug then begin @@ -510,7 +514,7 @@ let link_bytecode_as_c tolink outfile with_main = let sections = [ "SYMB", Symtable.data_global_map(); "PRIM", Obj.repr(Symtable.data_primitive_names()); - "CRCS", Obj.repr(extract_crc_interfaces()) ] in + "CRCS", Obj.repr(extract_crc_interfaces() |> Array.of_list) ] in output_string outchan "static char caml_sections[] = {\n"; output_data_string outchan (Marshal.to_string sections []); diff --git a/bytecomp/bytelink.mli b/bytecomp/bytelink.mli index 3a57ac3d711b..91df8fffe883 100644 --- a/bytecomp/bytelink.mli +++ b/bytecomp/bytelink.mli @@ -22,7 +22,7 @@ val reset : unit -> unit val check_consistency: filepath -> Cmo_format.compilation_unit_descr -> unit -val extract_crc_interfaces: unit -> Cmo_format.import_info list +val extract_crc_interfaces: unit -> Import_info.t list type error = | File_not_found of filepath diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index adc99dfaa48b..64313d20c589 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -221,7 +221,7 @@ let package_object_files ~ppf_dump files targetfile targetname coercion = let pos_final = pos_out oc in let imports = List.filter - (fun (name, _crc) -> not (List.mem name unit_names)) + (fun import -> not (List.mem (Import_info.name import) unit_names)) (Bytelink.extract_crc_interfaces()) in let for_pack_prefix = CU.Prefix.from_clflags () in let modname = targetname |> CU.Name.of_string in @@ -232,7 +232,10 @@ let package_object_files ~ppf_dump files targetfile targetname coercion = cu_codesize = pos_debug - pos_code; cu_reloc = List.rev !relocs; cu_imports = - (modname, Some (cu_name, Env.crc_of_unit modname)) :: imports; + Array.of_list + ((Import_info.create modname + ~crc_with_unit:(Some (cu_name, Env.crc_of_unit modname))) + :: imports); cu_primitives = !primitives; cu_required_globals = Compilation_unit.Set.elements required_globals; cu_force_link = !force_link; diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index f5ebca5b12b2..44c89de39617 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -412,7 +412,7 @@ let to_file outchan unit_name objfile ~required_globals code = cu_pos = pos_code; cu_codesize = !out_position; cu_reloc = List.rev !reloc_info; - cu_imports = Env.imports(); + cu_imports = Env.imports() |> Array.of_list; cu_primitives = List.map Primitive.byte_name !Translmod.primitive_declarations; cu_required_globals = Compilation_unit.Set.elements required_globals; diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index f8d44b686724..09ac3aa28261 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -316,8 +316,8 @@ let init_toplevel () = (* Recover CRC infos for interfaces *) let crcintfs = try - (Obj.magic (sect.read_struct "CRCS") : Cmo_format.import_info list) - with Not_found -> [] in + (Obj.magic (sect.read_struct "CRCS") : Import_info.t array) + with Not_found -> [| |] in (* Done *) sect.close_reader(); crcintfs diff --git a/bytecomp/symtable.mli b/bytecomp/symtable.mli index 78d210e550d0..60850b677935 100644 --- a/bytecomp/symtable.mli +++ b/bytecomp/symtable.mli @@ -32,7 +32,7 @@ val transl_const: Lambda.structured_constant -> Obj.t (* Functions for the toplevel *) -val init_toplevel: unit -> Cmo_format.import_info list +val init_toplevel: unit -> Import_info.t array val update_global_table: unit -> unit val get_global_value: Ident.t -> Obj.t val is_global_defined: Ident.t -> bool diff --git a/compilerlibs/Makefile.compilerlibs b/compilerlibs/Makefile.compilerlibs index 531c419a2f99..82c70eae94a5 100644 --- a/compilerlibs/Makefile.compilerlibs +++ b/compilerlibs/Makefile.compilerlibs @@ -47,6 +47,7 @@ UTILS = \ utils/target_system.cmo \ typing/ident.cmo \ utils/compilation_unit.cmo utils/linkage_name.cmo utils/symbol.cmo \ + utils/import_info.cmo \ utils/lazy_backtrack.cmo \ utils/diffing.cmo \ utils/diffing_with_keys.cmo diff --git a/configure b/configure index cdf0729707b0..62aafc23d0d0 100755 --- a/configure +++ b/configure @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.71 for OCaml 4.14.0. +# Generated by GNU Autoconf 2.71 for OCaml 4.14.0+jst. # # Report bugs to . # @@ -621,8 +621,8 @@ MAKEFLAGS= # Identity of this package. PACKAGE_NAME='OCaml' PACKAGE_TARNAME='ocaml' -PACKAGE_VERSION='4.14.0' -PACKAGE_STRING='OCaml 4.14.0' +PACKAGE_VERSION='4.14.0+jst' +PACKAGE_STRING='OCaml 4.14.0+jst' PACKAGE_BUGREPORT='caml-list@inria.fr' PACKAGE_URL='http://www.ocaml.org' @@ -1477,7 +1477,7 @@ if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures OCaml 4.14.0 to adapt to many kinds of systems. +\`configure' configures OCaml 4.14.0+jst to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1544,7 +1544,7 @@ fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of OCaml 4.14.0:";; + short | recursive ) echo "Configuration of OCaml 4.14.0+jst:";; esac cat <<\_ACEOF @@ -1717,7 +1717,7 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -OCaml configure 4.14.0 +OCaml configure 4.14.0+jst generated by GNU Autoconf 2.71 Copyright (C) 2021 Free Software Foundation, Inc. @@ -2374,7 +2374,7 @@ cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by OCaml $as_me 4.14.0, which was +It was created by OCaml $as_me 4.14.0+jst, which was generated by GNU Autoconf 2.71. Invocation command line was $ $0$ac_configure_args_raw @@ -3130,8 +3130,8 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: Configuring OCaml version 4.14.0" >&5 -printf "%s\n" "$as_me: Configuring OCaml version 4.14.0" >&6;} +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: Configuring OCaml version 4.14.0+jst" >&5 +printf "%s\n" "$as_me: Configuring OCaml version 4.14.0+jst" >&6;} # Configuration variables @@ -3179,11 +3179,11 @@ bootstrapping_flexdll=false -VERSION=4.14.0 +VERSION=4.14.0+jst OCAML_DEVELOPMENT_VERSION=false -OCAML_RELEASE_EXTRA=None +OCAML_RELEASE_EXTRA='Some (Plus, "jst")' OCAML_VERSION_MAJOR=4 @@ -3191,7 +3191,7 @@ OCAML_VERSION_MINOR=14 OCAML_VERSION_PATCHLEVEL=0 -OCAML_VERSION_EXTRA= +OCAML_VERSION_EXTRA=jst OCAML_VERSION_SHORT=4.14 @@ -3320,13 +3320,13 @@ printf "%s\n" "#define OCAML_VERSION_MINOR 14" >>confdefs.h printf "%s\n" "#define OCAML_VERSION_PATCHLEVEL 0" >>confdefs.h -printf "%s\n" "#define OCAML_VERSION_ADDITIONAL \"\"" >>confdefs.h +printf "%s\n" "#define OCAML_VERSION_ADDITIONAL \"jst\"" >>confdefs.h - printf "%s\n" "#define OCAML_VERSION_EXTRA \"\"" >>confdefs.h + printf "%s\n" "#define OCAML_VERSION_EXTRA \"jst\"" >>confdefs.h printf "%s\n" "#define OCAML_VERSION 41400" >>confdefs.h -printf "%s\n" "#define OCAML_VERSION_STRING \"4.14.0\"" >>confdefs.h +printf "%s\n" "#define OCAML_VERSION_STRING \"4.14.0+jst\"" >>confdefs.h # Checks for system types @@ -19676,7 +19676,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by OCaml $as_me 4.14.0, which was +This file was extended by OCaml $as_me 4.14.0+jst, which was generated by GNU Autoconf 2.71. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -19745,7 +19745,7 @@ ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ -OCaml config.status 4.14.0 +OCaml config.status 4.14.0+jst configured by $0, generated by GNU Autoconf 2.71, with options \\"\$ac_cs_config\\" diff --git a/dune b/dune index 1c7a32941a5d..22ab4c5c32ff 100644 --- a/dune +++ b/dune @@ -62,7 +62,7 @@ config build_path_prefix_map misc identifiable numbers arg_helper clflags profile terminfo ccomp warnings consistbl strongly_connected_components targetint load_path int_replace_polymorphic_compare domainstate binutils - local_store target_system compilation_unit linkage_name symbol + local_store target_system compilation_unit import_info linkage_name symbol lazy_backtrack diffing diffing_with_keys ;; PARSING diff --git a/file_formats/cmi_format.ml b/file_formats/cmi_format.ml index 888d654b2d2f..25aa4dea5736 100644 --- a/file_formats/cmi_format.ml +++ b/file_formats/cmi_format.ml @@ -32,9 +32,8 @@ exception Error of error they are used to provide consistency across input_value and output_value usage. *) type signature = Types.signature_item list -type import_info = - Compilation_unit.Name.t * (Compilation_unit.t * Digest.t) option -type crcs = import_info list + +type crcs = Import_info.t array (* smaller on disk than using a list *) type flags = pers_flags list type header = Compilation_unit.t * signature @@ -92,8 +91,8 @@ let output_cmi filename oc cmi = flush oc; let crc = Digest.file filename in let crcs = - (Compilation_unit.name cmi.cmi_name, Some (cmi.cmi_name, crc)) - :: cmi.cmi_crcs + Array.append [| Import_info.create_normal cmi.cmi_name ~crc:(Some crc) |] + cmi.cmi_crcs in output_value oc (crcs : crcs); output_value oc (cmi.cmi_flags : flags); diff --git a/file_formats/cmi_format.mli b/file_formats/cmi_format.mli index 6e5b0c4ecd9e..e510c50bb17d 100644 --- a/file_formats/cmi_format.mli +++ b/file_formats/cmi_format.mli @@ -21,13 +21,10 @@ type pers_flags = | Opaque | Unsafe_string -type import_info = - Compilation_unit.Name.t * (Compilation_unit.t * Digest.t) option - type cmi_infos = { cmi_name : Compilation_unit.t; cmi_sign : Types.signature_item list; - cmi_crcs : import_info list; + cmi_crcs : Import_info.t array; cmi_flags : pers_flags list; } diff --git a/file_formats/cmo_format.mli b/file_formats/cmo_format.mli index 2a2a686348c3..6c872e89bc73 100644 --- a/file_formats/cmo_format.mli +++ b/file_formats/cmo_format.mli @@ -25,15 +25,12 @@ type reloc_info = (* Descriptor for compilation units *) -type import_info = - Compilation_unit.Name.t * (Compilation_unit.t * Digest.t) option - type compilation_unit_descr = { cu_name: Compilation_unit.t; (* Name of 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: import_info list; (* Names and CRC of intfs imported *) + cu_imports: Import_info.t array; (* Names and CRC of intfs imported *) cu_required_globals: Compilation_unit.t list; (* Compilation units whose initialization side effects diff --git a/file_formats/cmt_format.ml b/file_formats/cmt_format.ml index bf187a4e8683..6c058ac2dba3 100644 --- a/file_formats/cmt_format.ml +++ b/file_formats/cmt_format.ml @@ -178,6 +178,13 @@ let save_cmt filename modname binary_annots sourcefile initial_env cmi shape = | Some cmi -> Some (output_cmi temp_file_name oc cmi) in let source_digest = Option.map Digest.file sourcefile in + let get_imports () = + Env.imports () + |> List.map (fun import -> + let name = Import_info.name import in + let crc_with_unit = Import_info.crc_with_unit import in + name, crc_with_unit) + in let compare_imports (modname1, _crc1) (modname2, _crc2) = Compilation_unit.Name.compare modname1 modname2 in @@ -193,7 +200,7 @@ let save_cmt filename modname binary_annots sourcefile initial_env cmi shape = cmt_source_digest = source_digest; cmt_initial_env = if need_to_clear_env then keep_only_summary initial_env else initial_env; - cmt_imports = List.sort compare_imports (Env.imports ()); + cmt_imports = List.sort compare_imports (get_imports ()); cmt_interface_digest = this_crc; cmt_use_summaries = need_to_clear_env; cmt_uid_to_loc = Env.get_uid_to_loc_tbl (); diff --git a/file_formats/cmt_format.mli b/file_formats/cmt_format.mli index 1a62f7c791c2..8574138ce578 100644 --- a/file_formats/cmt_format.mli +++ b/file_formats/cmt_format.mli @@ -48,6 +48,8 @@ and binary_part = | Partial_signature_item of signature_item | Partial_module_type of module_type +(* CR mshinwell: this should be removed in favour of [Import_info.t], + but will require a new Merlin *) type import_info = (Compilation_unit.Name.t * (Compilation_unit.t * Digest.t) option) diff --git a/file_formats/cmx_format.mli b/file_formats/cmx_format.mli index 4b5b321fb0c0..3053a1a72d7a 100644 --- a/file_formats/cmx_format.mli +++ b/file_formats/cmx_format.mli @@ -19,11 +19,6 @@ (* Format of .cmx, .cmxa and .cmxs files *) -type import_info_cmi = - Compilation_unit.Name.t * (Compilation_unit.t * Digest.t) option -type import_info_cmx = - Compilation_unit.t * Digest.t option - (* Each .o file has a matching .cmx file that provides the following infos on the compilation unit: - list of other units imported, with MD5s of their .cmx files @@ -45,9 +40,9 @@ type unit_infos = (* All compilation units in the .cmx file (i.e. [ui_name] and any produced via [Asmpackager]) *) - mutable ui_imports_cmi: import_info_cmi list; + mutable ui_imports_cmi: Import_info.t array; (* Interfaces imported *) - mutable ui_imports_cmx: import_info_cmx list; + mutable ui_imports_cmx: Import_info.t array; (* Infos imported *) mutable ui_curry_fun: Clambda.arity list; (* Currying functions needed *) mutable ui_apply_fun: apply_fn list; (* Apply functions needed *) diff --git a/file_formats/cmxs_format.mli b/file_formats/cmxs_format.mli index 6e3f703997c7..1f67c27fa8d9 100644 --- a/file_formats/cmxs_format.mli +++ b/file_formats/cmxs_format.mli @@ -22,9 +22,8 @@ type dynunit = { dynu_name: Compilation_unit.t; dynu_crc: Digest.t; - dynu_imports_cmi: - (Compilation_unit.Name.t * (Compilation_unit.t * Digest.t) option) list; - dynu_imports_cmx: (Compilation_unit.t * Digest.t option) list; + dynu_imports_cmi: Import_info.t array; + dynu_imports_cmx: Import_info.t array; dynu_defines: Compilation_unit.t list; } diff --git a/middle_end/compilenv.ml b/middle_end/compilenv.ml index f126fdc45df0..5c3e4f65b469 100644 --- a/middle_end/compilenv.ml +++ b/middle_end/compilenv.ml @@ -81,8 +81,8 @@ let default_ui_export_info = let current_unit = { ui_unit = CU.dummy; ui_defines = []; - ui_imports_cmi = []; - ui_imports_cmx = []; + ui_imports_cmi = [| |]; + ui_imports_cmx = [| |]; ui_curry_fun = []; ui_apply_fun = []; ui_send_fun = []; @@ -95,8 +95,8 @@ let reset compilation_unit = CU.set_current (Some compilation_unit); current_unit.ui_unit <- compilation_unit; current_unit.ui_defines <- [compilation_unit]; - current_unit.ui_imports_cmi <- []; - current_unit.ui_imports_cmx <- []; + current_unit.ui_imports_cmi <- [| |]; + current_unit.ui_imports_cmx <- [| |]; current_unit.ui_curry_fun <- []; current_unit.ui_apply_fun <- []; current_unit.ui_send_fun <- []; @@ -161,8 +161,9 @@ let get_unit_info comp_unit ~cmx_name = (None, None) end in + let import = Import_info.create_normal comp_unit ~crc in current_unit.ui_imports_cmx <- - (comp_unit, crc) :: current_unit.ui_imports_cmx; + Array.append [| import |] current_unit.ui_imports_cmx; CU.Name.Tbl.add global_infos_table cmx_name infos; infos end @@ -261,7 +262,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 <- Array.of_list (Env.imports()); write_unit_info current_unit filename let snapshot () = !structured_constants diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile index 902a01f75c8a..4a82710d9bec 100644 --- a/otherlibs/dynlink/Makefile +++ b/otherlibs/dynlink/Makefile @@ -87,6 +87,7 @@ COMPILERLIBS_SOURCES=\ utils/int_replace_polymorphic_compare.ml \ typing/ident.ml \ utils/compilation_unit.ml \ + utils/import_info.ml \ utils/linkage_name.ml \ utils/symbol.ml \ utils/lazy_backtrack.ml \ diff --git a/otherlibs/dynlink/dune b/otherlibs/dynlink/dune index a112821c40d6..e4b237b6df25 100644 --- a/otherlibs/dynlink/dune +++ b/otherlibs/dynlink/dune @@ -75,6 +75,7 @@ cmxs_format debug_event compilation_unit + import_info symbol linkage_name) (modules_without_implementation @@ -111,6 +112,7 @@ (copy_files ../../utils/load_path.ml) (copy_files ../../utils/int_replace_polymorphic_compare.ml) (copy_files ../../utils/compilation_unit.ml) +(copy_files ../../utils/import_info.ml) (copy_files ../../utils/symbol.ml) (copy_files ../../utils/linkage_name.ml) (copy_files ../../utils/lazy_backtrack.ml) @@ -162,6 +164,7 @@ (copy_files ../../utils/load_path.mli) (copy_files ../../utils/int_replace_polymorphic_compare.mli) (copy_files ../../utils/compilation_unit.mli) +(copy_files ../../utils/import_info.mli) (copy_files ../../utils/symbol.mli) (copy_files ../../utils/linkage_name.mli) (copy_files ../../utils/lazy_backtrack.mli) @@ -253,6 +256,7 @@ .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Ident.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Longident.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Compilation_unit.cmo + .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Import_info.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Linkage_name.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Symbol.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Path.cmo @@ -319,6 +323,7 @@ .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Ident.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Longident.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Compilation_unit.cmx + .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Import_info.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Linkage_name.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Symbol.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Path.cmx diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml index a74e5b19d7ac..084b667cbebb 100644 --- a/otherlibs/dynlink/dynlink.ml +++ b/otherlibs/dynlink/dynlink.ml @@ -23,9 +23,10 @@ open! Dynlink_compilerlibs module DC = Dynlink_common module DT = Dynlink_types -let convert_cmi_import (name, data) = - (name |> Compilation_unit.Name.to_string), - Option.map (fun (_unit, crc) -> crc) data +let convert_cmi_import import = + let name = Import_info.name import |> Compilation_unit.Name.to_string in + let crc = Import_info.crc import in + name, crc module Bytecode = struct type filename = string @@ -37,7 +38,7 @@ module Bytecode = struct let crc _t = None let interface_imports (t : t) = - List.map convert_cmi_import t.cu_imports + List.map convert_cmi_import (Array.to_list t.cu_imports) let implementation_imports (t : t) = let required_from_unit = @@ -68,7 +69,7 @@ module Bytecode = struct type handle = Stdlib.in_channel * filename * Digest.t - let default_crcs = ref [] + let default_crcs = ref [| |] let default_global_map = ref Symtable.empty_global_map let init () = @@ -89,7 +90,9 @@ module Bytecode = struct Compilation_unit.create Compilation_unit.Prefix.empty modname let fold_initial_units ~init ~f = - List.fold_left (fun acc (modname, interface) -> + Array.fold_left (fun acc import -> + let modname = Import_info.name import in + let crc = Import_info.crc import in let id = Compilation_unit.to_global_ident_for_bytecode (assume_no_prefix modname) @@ -97,9 +100,6 @@ module Bytecode = struct let defined = Symtable.is_defined_in_global_map !default_global_map id in - let interface = - Option.map (fun (_unit, crc) -> crc) interface - in let implementation = if defined then Some (None, DT.Loaded) else None @@ -109,7 +109,7 @@ module Bytecode = struct else [] in let comp_unit = modname |> Compilation_unit.Name.to_string in - f acc ~comp_unit ~interface ~implementation ~defined_symbols) + f acc ~comp_unit ~interface:crc ~implementation ~defined_symbols) init !default_crcs @@ -236,13 +236,15 @@ module Native = struct let name (t : t) = t.dynu_name |> Compilation_unit.name_as_string let crc (t : t) = Some t.dynu_crc - let convert_cmx_import (name, crc) = - (name |> Compilation_unit.name_as_string), crc + let convert_cmx_import import = + let cu = Import_info.cu import |> Compilation_unit.name_as_string in + let crc = Import_info.crc import in + cu, crc let interface_imports (t : t) = - List.map convert_cmi_import t.dynu_imports_cmi + List.map convert_cmi_import (Array.to_list t.dynu_imports_cmi) let implementation_imports (t : t) = - List.map convert_cmx_import t.dynu_imports_cmx + List.map convert_cmx_import (Array.to_list t.dynu_imports_cmx) let defined_symbols (t : t) = List.map (fun comp_unit -> diff --git a/otherlibs/dynlink/extract_crc.ml b/otherlibs/dynlink/extract_crc.ml index 3864e73eaef3..8a3deef3cbdc 100644 --- a/otherlibs/dynlink/extract_crc.ml +++ b/otherlibs/dynlink/extract_crc.ml @@ -43,8 +43,11 @@ let digest_interface unit loadpath = let cmi = Cmi_format.input_cmi ic in close_in ic; let crc = - match cmi.Cmi_format.cmi_crcs with - (_, Some (_unit, crc)) :: _ -> crc + match cmi.Cmi_format.cmi_crcs |> Array.to_list with + import :: _ -> + (match Import_info.crc import with + | Some crc -> crc + | None -> raise Corrupted_interface) | _ -> raise Corrupted_interface in crc diff --git a/testsuite/tests/lib-dynlink-initializers/test10_main.native.reference b/testsuite/tests/lib-dynlink-initializers/test10_main.native.reference index 49e82b6e5f96..4d03df31994c 100755 --- a/testsuite/tests/lib-dynlink-initializers/test10_main.native.reference +++ b/testsuite/tests/lib-dynlink-initializers/test10_main.native.reference @@ -3,9 +3,9 @@ Raised at Stdlib.failwith in file "stdlib.ml", line 32, characters 17-33 Called from Test10_plugin.g in file "test10_plugin.ml" (inlined), line 2, characters 15-38 Called from Test10_plugin.f in file "test10_plugin.ml", line 6, characters 2-6 Called from Test10_plugin in file "test10_plugin.ml", line 10, characters 2-6 -Called from Dynlink.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 290, characters 8-25 -Called from Dynlink.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 290, characters 8-25 -Re-raised at Dynlink.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 302, characters 6-137 +Called from Dynlink.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 292, characters 8-25 +Called from Dynlink.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 292, characters 8-25 +Re-raised at Dynlink.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 304, characters 6-137 Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 Called from Dynlink_common.Make.load.(fun) in file "otherlibs/dynlink/dynlink_common.ml", line 337, characters 13-54 Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 diff --git a/testsuite/tests/tool-ocamlobjinfo/question.ml b/testsuite/tests/tool-ocamlobjinfo/question.ml index 0b42dd1f9dfd..43c440b2a214 100644 --- a/testsuite/tests/tool-ocamlobjinfo/question.ml +++ b/testsuite/tests/tool-ocamlobjinfo/question.ml @@ -8,6 +8,13 @@ program = "question.cmxs" **** check-ocamlopt.byte-output ***** ocamlobjinfo ****** check-program-output + +***** ocamlobjinfo +program = "question.cmx" +(* The cmx output varies too much to check. We're just happy it didn't + segfault on us. *) *) -let answer = 42 +(* We use a function rather than a value of type int to ensure that there + is an Flambda 2 code section. *) +let answer () = 42 diff --git a/tools/objinfo.ml b/tools/objinfo.ml index 6dfc32f465df..d74b898118d8 100644 --- a/tools/objinfo.ml +++ b/tools/objinfo.ml @@ -50,7 +50,7 @@ let null_crc = String.make 32 '0' let string_of_crc crc = if !no_crc then null_crc else Digest.to_hex crc -let print_name_crc (name, crco) = +let print_name_crc name crco = let crc = match crco with None -> dummy_crc @@ -58,12 +58,21 @@ let print_name_crc (name, crco) = in printf "\t%s\t%a\n" crc Compilation_unit.Name.output name -let print_intf_import (name, data) = - let crco = data |> Option.map (fun (_unit, crc) -> crc) in - print_name_crc (name, crco) +(* CR-someday mshinwell: consider moving to [Import_info.print] *) + +let print_intf_import import = + let name = Import_info.name import in + let crco = Import_info.crc import in + print_name_crc name crco -let print_impl_import (unit, crco) = - print_name_crc (Compilation_unit.name unit, crco) +let print_impl_import import = + let unit = Import_info.cu import in + let crco = Import_info.crc import in + print_name_crc (Compilation_unit.name unit) crco + +let print_old_intf_import (name, data) = + let crco = data |> Option.map (fun (_unit, crc) -> crc) in + print_name_crc name crco let print_line name = printf "\t%s\n" name @@ -77,7 +86,7 @@ let print_required_global id = let print_cmo_infos cu = printf "Unit name: %a\n" Compilation_unit.output cu.cu_name; print_string "Interfaces imported:\n"; - List.iter print_intf_import cu.cu_imports; + Array.iter print_intf_import cu.cu_imports; print_string "Required globals:\n"; List.iter print_required_global cu.cu_required_globals; printf "Uses unsafe features: "; @@ -108,13 +117,13 @@ let print_cma_infos (lib : Cmo_format.library) = let print_cmi_infos name crcs = printf "Unit name: %a\n" Compilation_unit.output name; printf "Interfaces imported:\n"; - List.iter print_intf_import crcs + Array.iter print_intf_import crcs let print_cmt_infos cmt = let open Cmt_format in printf "Cmt unit name: %a\n" Compilation_unit.output cmt.cmt_modname; print_string "Cmt interfaces imported:\n"; - List.iter print_intf_import cmt.cmt_imports; + List.iter print_old_intf_import cmt.cmt_imports; printf "Source file: %s\n" (match cmt.cmt_sourcefile with None -> "(none)" | Some f -> f); printf "Compilation flags:"; @@ -143,9 +152,9 @@ let print_general_infos name crc defines cmi cmx = printf "Globals defined:\n"; List.iter print_line (List.map linkage_name defines); printf "Interfaces imported:\n"; - List.iter print_intf_import cmi; + Array.iter print_intf_import cmi; printf "Implementations imported:\n"; - List.iter print_impl_import cmx + Array.iter print_impl_import cmx let print_global_table table = printf "Globals defined:\n"; @@ -240,7 +249,7 @@ let dump_byte ic = p_list "Imported units" print_intf_import - (input_value ic : Cmo_format.import_info list) + ((input_value ic : Import_info.t array) |> Array.to_list) | "DLLS" -> p_list "Used DLLs" diff --git a/toplevel/expunge.ml b/toplevel/expunge.ml index 268ec8521dce..56ba0ae57bac 100644 --- a/toplevel/expunge.ml +++ b/toplevel/expunge.ml @@ -36,9 +36,11 @@ let expunge_map tbl = Symtable.filter_global_map (fun id -> keep (Ident.name id)) tbl let expunge_crcs tbl = - List.filter - (fun (unit, _crc) -> keep (unit |> Compilation_unit.Name.to_string)) - tbl + Array.to_list tbl + |> List.filter + (fun import -> + keep (Import_info.name import |> Compilation_unit.Name.to_string)) + |> Array.of_list let main () = let input_name = Sys.argv.(1) in @@ -65,7 +67,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 : Cmo_format.import_info list) in + let crcs = (input_value ic : Import_info.t array) in output_value oc (expunge_crcs crcs) | _ -> copy_file_chunk ic oc len diff --git a/typing/env.mli b/typing/env.mli index ffdd514b1dd5..2e3df10b7e21 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -411,7 +411,7 @@ val save_signature: (* Arguments: signature, module name, file name. *) val save_signature_with_imports: alerts:alerts -> signature -> Compilation_unit.t -> filepath - -> Cmi_format.import_info list + -> Import_info.t array -> Cmi_format.cmi_infos (* Arguments: signature, module name, file name, imported units with their CRCs. *) @@ -420,10 +420,10 @@ val save_signature_with_imports: val crc_of_unit: Compilation_unit.Name.t -> Digest.t (* Return the set of compilation units imported, with their CRC *) -val imports: unit -> Cmi_format.import_info list +val imports: unit -> Import_info.t list (* may raise Persistent_env.Consistbl.Inconsistency *) -val import_crcs: source:string -> Cmi_format.import_info list -> unit +val import_crcs: source:string -> Import_info.t array -> unit (* [is_imported_opaque md] returns true if [md] is an opaque imported module *) val is_imported_opaque: Compilation_unit.Name.t -> bool diff --git a/typing/persistent_env.ml b/typing/persistent_env.ml index 2a4aae4f39bb..1a4c63dbe3ce 100644 --- a/typing/persistent_env.ml +++ b/typing/persistent_env.ml @@ -19,20 +19,21 @@ open Misc open Cmi_format -module Consistbl = Consistbl.Make (Compilation_unit.Name) (Compilation_unit) +module CU = Compilation_unit +module Consistbl = Consistbl.Make (CU.Name) (CU) let add_delayed_check_forward = ref (fun _ -> assert false) type error = - | Illegal_renaming of Compilation_unit.Name.t * Compilation_unit.Name.t * filepath - | Inconsistent_import of Compilation_unit.Name.t * filepath * filepath - | Need_recursive_types of Compilation_unit.t - | Depend_on_unsafe_string_unit of Compilation_unit.t - | Inconsistent_package_declaration of Compilation_unit.t * filepath + | Illegal_renaming of CU.Name.t * CU.Name.t * filepath + | Inconsistent_import of CU.Name.t * filepath * filepath + | Need_recursive_types of CU.t + | Depend_on_unsafe_string_unit of CU.t + | Inconsistent_package_declaration of CU.t * filepath | Inconsistent_package_declaration_between_imports of - filepath * Compilation_unit.t * Compilation_unit.t + filepath * CU.t * CU.t | Direct_reference_from_wrong_package of - Compilation_unit.t * filepath * Compilation_unit.Prefix.t + CU.t * filepath * CU.Prefix.t exception Error of error let error err = raise (Error err) @@ -43,7 +44,7 @@ module Persistent_signature = struct cmi : Cmi_format.cmi_infos } let load = ref (fun ~unit_name -> - let unit_name = Compilation_unit.Name.to_string unit_name in + let unit_name = CU.Name.to_string unit_name in match Load_path.find_uncap (unit_name ^ ".cmi") with | filename -> Some { filename; cmi = read_cmi filename } | exception Not_found -> None) @@ -54,8 +55,8 @@ type can_load_cmis = | Cannot_load_cmis of Lazy_backtrack.log type pers_struct = { - ps_name: Compilation_unit.t; - ps_crcs: Cmi_format.import_info list; + ps_name: CU.t; + ps_crcs: Import_info.t array; ps_filename: string; ps_flags: pers_flags list; } @@ -68,17 +69,17 @@ type 'a pers_struct_info = type 'a t = { persistent_structures : - (Compilation_unit.Name.t, 'a pers_struct_info) Hashtbl.t; - imported_units: Compilation_unit.Name.Set.t ref; - imported_opaque_units: Compilation_unit.Name.Set.t ref; + (CU.Name.t, 'a pers_struct_info) Hashtbl.t; + imported_units: CU.Name.Set.t ref; + imported_opaque_units: CU.Name.Set.t ref; crc_units: Consistbl.t; can_load_cmis: can_load_cmis ref; } let empty () = { persistent_structures = Hashtbl.create 17; - imported_units = ref Compilation_unit.Name.Set.empty; - imported_opaque_units = ref Compilation_unit.Name.Set.empty; + imported_units = ref CU.Name.Set.empty; + imported_opaque_units = ref CU.Name.Set.empty; crc_units = Consistbl.create (); can_load_cmis = ref Can_load_cmis; } @@ -92,8 +93,8 @@ let clear penv = can_load_cmis; } = penv in Hashtbl.clear persistent_structures; - imported_units := Compilation_unit.Name.Set.empty; - imported_opaque_units := Compilation_unit.Name.Set.empty; + imported_units := CU.Name.Set.empty; + imported_opaque_units := CU.Name.Set.empty; Consistbl.clear crc_units; can_load_cmis := Can_load_cmis; () @@ -107,10 +108,10 @@ let clear_missing {persistent_structures; _} = List.iter (Hashtbl.remove persistent_structures) missing_entries let add_import {imported_units; _} s = - imported_units := Compilation_unit.Name.Set.add s !imported_units + imported_units := CU.Name.Set.add s !imported_units let register_import_as_opaque {imported_opaque_units; _} s = - imported_opaque_units := Compilation_unit.Name.Set.add s !imported_opaque_units + imported_opaque_units := CU.Name.Set.add s !imported_opaque_units let find_in_cache {persistent_structures; _} s = match Hashtbl.find persistent_structures s with @@ -120,13 +121,15 @@ let find_in_cache {persistent_structures; _} s = let import_crcs penv ~source crcs = let {crc_units; _} = penv in - let import_crc (name, crco) = + let import_crc import_info = + let name = Import_info.name import_info in + let crco = Import_info.crc_with_unit import_info in match crco with | None -> () | Some (unit, crc) -> add_import penv name; Consistbl.check crc_units name unit crc source - in List.iter import_crc crcs + in Array.iter import_crc crcs let check_consistency penv ps = try import_crcs penv ~source:ps.ps_filename ps.ps_crcs @@ -137,7 +140,7 @@ let check_consistency penv ps = inconsistent_data = source_unit; original_data = auth_unit; } -> - if Compilation_unit.equal source_unit auth_unit + if CU.equal source_unit auth_unit then error (Inconsistent_import(name, auth, source)) else error (Inconsistent_package_declaration_between_imports( ps.ps_filename, auth_unit, source_unit)) @@ -167,7 +170,7 @@ let fold {persistent_structures; _} f x = let save_pers_struct penv crc ps pm = let {persistent_structures; crc_units; _} = penv in - let modname = Compilation_unit.name ps.ps_name in + let modname = CU.name ps.ps_name in Hashtbl.add persistent_structures modname (Found (ps, pm)); List.iter (function @@ -189,8 +192,8 @@ let acknowledge_pers_struct penv check modname pers_sig pm = ps_filename = filename; ps_flags = flags; } in - let found_name = Compilation_unit.name name in - if not (Compilation_unit.Name.equal modname found_name) then + let found_name = CU.name name in + if not (CU.Name.equal modname found_name) then error (Illegal_renaming(modname, found_name, filename)); List.iter (function @@ -204,13 +207,13 @@ let acknowledge_pers_struct penv check modname pers_sig pm = | Opaque -> register_import_as_opaque penv modname) ps.ps_flags; if check then check_consistency penv ps; - begin match Compilation_unit.get_current () with + begin match CU.get_current () with | Some current_unit -> let access_allowed = - Compilation_unit.can_access_by_name name ~accessed_by:current_unit + CU.can_access_by_name name ~accessed_by:current_unit in if not access_allowed then - let prefix = Compilation_unit.for_pack_prefix current_unit in + let prefix = CU.for_pack_prefix current_unit in error (Direct_reference_from_wrong_package (name, filename, prefix)); | None -> () end; @@ -228,7 +231,7 @@ let read_pers_struct penv val_of_pers_sig check modname filename = let find_pers_struct penv val_of_pers_sig check name = let {persistent_structures; _} = penv in - if Compilation_unit.Name.equal name Compilation_unit.Name.predef_exn then raise Not_found; + if CU.Name.equal name CU.Name.predef_exn then raise Not_found; match Hashtbl.find persistent_structures name with | Found (ps, pm) -> (ps, pm) | Missing -> raise Not_found @@ -249,14 +252,14 @@ let find_pers_struct penv val_of_pers_sig check name = (ps, pm) let describe_prefix ppf prefix = - if Compilation_unit.Prefix.is_empty prefix then + if CU.Prefix.is_empty prefix then Format.fprintf ppf "outside of any package" else - Format.fprintf ppf "package %a" Compilation_unit.Prefix.print prefix + Format.fprintf ppf "package %a" CU.Prefix.print prefix (* Emits a warning if there is no valid cmi for name *) let check_pers_struct penv f ~loc name = - let name_as_string = Compilation_unit.Name.to_string name in + let name_as_string = CU.Name.to_string name in try ignore (find_pers_struct penv f false name) with @@ -275,21 +278,21 @@ let check_pers_struct penv f ~loc name = " %a@ contains the compiled interface for @ \ %a when %a was expected" Location.print_filename filename - Compilation_unit.Name.print ps_name - Compilation_unit.Name.print name + CU.Name.print ps_name + CU.Name.print name | Inconsistent_import _ -> assert false | Need_recursive_types name -> Format.asprintf "%a uses recursive types" - Compilation_unit.print name + CU.print name | Depend_on_unsafe_string_unit name -> Format.asprintf "%a uses -unsafe-string" - Compilation_unit.print name + CU.print name | Inconsistent_package_declaration _ -> assert false | Inconsistent_package_declaration_between_imports _ -> assert false | Direct_reference_from_wrong_package (unit, _filename, prefix) -> Format.asprintf "%a is inaccessible from %a" - Compilation_unit.print unit + CU.print unit describe_prefix prefix in let warn = Warnings.No_cmi_file(name_as_string, Some msg) in @@ -313,30 +316,49 @@ let check penv f ~loc name = (fun () -> check_pers_struct penv f ~loc name) end +(* CR mshinwell: delete this having moved to 4.14 build compilers *) +module Array = struct + include Array + + (* From stdlib/array.ml *) + let find_opt p a = + let n = Array.length a in + let rec loop i = + if i = n then None + else + let x = Array.unsafe_get a i in + if p x then Some x + else loop (succ i) + in + loop 0 +end + let crc_of_unit penv f name = let (ps, _pm) = find_pers_struct penv f true 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 + match Array.find_opt (Import_info.has_name ~name) ps.ps_crcs with + | None -> assert false + | Some import_info -> + match Import_info.crc import_info with + | None -> assert false + | Some crc -> crc let imports {imported_units; crc_units; _} = - Consistbl.extract (Compilation_unit.Name.Set.elements !imported_units) - crc_units + let imports = + Consistbl.extract (CU.Name.Set.elements !imported_units) + crc_units + in + List.map (fun (cu_name, crc_with_unit) -> + Import_info.create cu_name ~crc_with_unit) + imports let looked_up {persistent_structures; _} modname = Hashtbl.mem persistent_structures modname let is_imported {imported_units; _} s = - Compilation_unit.Name.Set.mem s !imported_units + CU.Name.Set.mem s !imported_units let is_imported_opaque {imported_opaque_units; _} s = - Compilation_unit.Name.Set.mem s !imported_opaque_units + CU.Name.Set.mem s !imported_opaque_units let make_cmi penv modname sign alerts = let flags = @@ -351,7 +373,7 @@ let make_cmi penv modname sign alerts = { cmi_name = modname; cmi_sign = sign; - cmi_crcs = crcs; + cmi_crcs = Array.of_list crcs; cmi_flags = flags } @@ -373,8 +395,9 @@ let save_cmi penv psig pm = let ps = { ps_name = modname; ps_crcs = - (Compilation_unit.name cmi.cmi_name, Some (cmi.cmi_name, crc)) - :: imports; + Array.append + [| Import_info.create_normal cmi.cmi_name ~crc:(Some crc) |] + imports; ps_filename = filename; ps_flags = flags; } in @@ -389,39 +412,39 @@ let report_error ppf = "Wrong file naming: %a@ contains the compiled interface for@ \ %a when %a was expected" Location.print_filename filename - Compilation_unit.Name.print ps_name - Compilation_unit.Name.print modname + CU.Name.print ps_name + CU.Name.print modname | Inconsistent_import(name, source1, source2) -> fprintf ppf "@[The files %a@ and %a@ \ make inconsistent assumptions@ over interface %a@]" Location.print_filename source1 Location.print_filename source2 - Compilation_unit.Name.print name + CU.Name.print name | Need_recursive_types(import) -> fprintf ppf "@[Invalid import of %a, which uses recursive types.@ %s@]" - Compilation_unit.print import + CU.print import "The compilation flag -rectypes is required" | Depend_on_unsafe_string_unit(import) -> fprintf ppf "@[Invalid import of %a, compiled with -unsafe-string.@ %s@]" - Compilation_unit.print import + CU.print import "This compiler has been configured in strict \ safe-string mode (-force-safe-string)" | Inconsistent_package_declaration(intf_package, intf_filename) -> fprintf ppf "@[The interface %a@ is compiled for package %s.@ %s@]" - Compilation_unit.print intf_package intf_filename + CU.print intf_package intf_filename "The compilation flag -for-pack with the same package is required" | Inconsistent_package_declaration_between_imports (filename, unit1, unit2) -> fprintf ppf "@[The file %s@ is imported both as %a@ and as %a.@]" filename - Compilation_unit.print unit1 - Compilation_unit.print unit2 + CU.print unit1 + CU.print unit2 | Direct_reference_from_wrong_package(unit, filename, prefix) -> fprintf ppf "@[Invalid reference to %a (in file %s) from %a.@ %s]" - Compilation_unit.print unit + CU.print unit filename describe_prefix prefix "Can only access members of this library's package or a containing package" diff --git a/typing/persistent_env.mli b/typing/persistent_env.mli index 3f4cf4e1cb2d..59437bf76b5b 100644 --- a/typing/persistent_env.mli +++ b/typing/persistent_env.mli @@ -98,10 +98,11 @@ val without_cmis : 'a t -> ('b -> 'c) -> 'b -> 'c allow [penv] to openi cmis during its execution *) (* may raise Consistbl.Inconsistency *) -val import_crcs : 'a t -> source:filepath -> Cmi_format.import_info list -> unit +val import_crcs : 'a t -> source:filepath -> + Import_info.t array -> unit (* Return the set of compilation units imported, with their CRC *) -val imports : 'a t -> Cmi_format.import_info list +val imports : 'a t -> Import_info.t list (* Return the CRC of the interface of the given compilation unit *) val crc_of_unit: 'a t -> (Persistent_signature.t -> 'a) diff --git a/typing/typecore.ml b/typing/typecore.ml index 4a85c5aab0f1..352c0ae87048 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -2766,8 +2766,7 @@ let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs ret_tvar in loop ty_fun mode_fun rev_args sargs -let collect_apply_args env funct ignore_labels - ty_fun ty_fun0 mode_fun sargs ret_tvar = +let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs ret_tvar = let warned = ref false in let rec loop ty_fun ty_fun0 mode_fun rev_args sargs = let ty_fun' = expand_head env ty_fun in diff --git a/typing/typemod.ml b/typing/typemod.ml index bb27a94da6dd..d6d0e4136e50 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -3324,15 +3324,16 @@ let package_units initial_env objfiles cmifile modulename = (* Determine imports *) let unit_names = List.map fst units in let imports = - List.filter - (fun (name, _crc) -> not (List.mem name unit_names)) + List.filter (fun import -> + let name = Import_info.name import in + not (List.mem name unit_names)) (Env.imports()) in (* Write packaged signature *) if not !Clflags.dont_write_files then begin let cmi = Env.save_signature_with_imports ~alerts:Misc.Stdlib.String.Map.empty sg modulename - (prefix ^ ".cmi") imports + (prefix ^ ".cmi") (Array.of_list imports) in Cmt_format.save_cmt (prefix ^ ".cmt") modulename (Cmt_format.Packed (cmi.Cmi_format.cmi_sign, objfiles)) None initial_env diff --git a/utils/.ocamlformat b/utils/.ocamlformat new file mode 100644 index 000000000000..a6f157798c06 --- /dev/null +++ b/utils/.ocamlformat @@ -0,0 +1,17 @@ +# Please make a pull request to change this file. +disable=true +# There is an .ocamlformat-enable file in this directory. +# Keep the remainder of this file in sync with other .ocamlformat files in this repo. +assignment-operator=begin-line +cases-exp-indent=2 +doc-comments=before +dock-collection-brackets=false +if-then-else=keyword-first +module-item-spacing=sparse +parens-tuple=multi-line-only +sequence-blank-line=compact +space-around-lists=false +space-around-variants=false +type-decl=sparse +wrap-comments=true +version=0.24.1 diff --git a/utils/.ocamlformat-enable b/utils/.ocamlformat-enable new file mode 100644 index 000000000000..dc0bce1feedb --- /dev/null +++ b/utils/.ocamlformat-enable @@ -0,0 +1,4 @@ +compilation_unit.ml +compilation_unit.mli +import_info.ml +import_info.mli diff --git a/utils/compilation_unit.ml b/utils/compilation_unit.ml index 34f3bf59a086..f79194fff66a 100644 --- a/utils/compilation_unit.ml +++ b/utils/compilation_unit.ml @@ -17,7 +17,6 @@ [@@@ocaml.warning "+a-9-40-41-42"] open! Int_replace_polymorphic_compare - module List = Misc.Stdlib.List module String = Misc.Stdlib.String @@ -41,17 +40,23 @@ let output_of_print print = module Name : sig type t + include Identifiable.S with type t := t + val dummy : t + val predef_exn : t + val of_string : string -> t + val to_string : t -> string + val check_as_path_component : t -> unit end = struct (* Be VERY careful changing this. Anything not equivalent to [string] will require bumping magic numbers due to changes in file formats, in addition to breaking the (somewhat horrifying) invariant on - [Cmm_helpers.globals_map]. Furthermore there are uses of polymorphic + [Cmm_helpers.globals_map]. Furthermore there are uses of polymorphic compare hidden in [List.mem], [List.assoc] etc. *) type t = string @@ -59,14 +64,17 @@ end = struct type nonrec t = t let compare = String.compare + let equal = String.equal + let hash = Hashtbl.hash + let print = String.print + let output = output_of_print print end) - let isupper chr = - Char.equal (Char.uppercase_ascii chr) chr + let isupper chr = Char.equal (Char.uppercase_ascii chr) chr let of_string str = if String.equal str "" @@ -78,8 +86,8 @@ end = struct executables to have names like ".cinaps" that aren't valid module names. *) let check_as_path_component t = if String.length t < 1 - || not (isupper (String.get t 0)) - || String.contains t '.' + || (not (isupper (String.get t 0))) + || String.contains t '.' then raise (Error (Bad_compilation_unit_name t)) let dummy = "*dummy*" @@ -91,13 +99,21 @@ end module Prefix : sig type t + include Identifiable.S with type t := t + val parse_for_pack : string -> t + val from_clflags : unit -> t + val of_list : Name.t list -> t + val to_list : t -> Name.t list + val to_string : t -> string + val empty : t + val is_empty : t -> bool end = struct (* As with [Name.t], changing this will change several file formats, requiring @@ -123,21 +139,22 @@ end = struct let is_valid_character first_char c = let code = Char.code c in - if first_char then - code >= 65 && code <= 90 (* [A-Z] *) + if first_char + then code >= 65 && code <= 90 (* [A-Z] *) else Char.equal c '_' - || code >= 48 && 57 <= 90 (* [0-9] *) - || code >= 65 && code <= 90 (* [A-Z] *) - || code >= 97 && code <= 122 (* [a-z] *) + || (code >= 48 && 57 <= 90 (* [0-9] *)) + || (code >= 65 && code <= 90 (* [A-Z] *)) + || (code >= 97 && code <= 122 (* [a-z] *)) let parse_for_pack pack = let prefix = String.split_on_char '.' pack in ListLabels.iter prefix ~f:(fun module_name -> - String.iteri (fun i c -> - if not (is_valid_character (i=0) c) then - raise (Error (Invalid_character (c, module_name)))) - module_name); + String.iteri + (fun i c -> + if not (is_valid_character (i = 0) c) + then raise (Error (Invalid_character (c, module_name)))) + module_name); ListLabels.map prefix ~f:Name.of_string let from_clflags () = @@ -145,56 +162,83 @@ end = struct | None -> [] | Some pack -> parse_for_pack pack - let to_string p = - Format.asprintf "%a" print p + let to_string p = Format.asprintf "%a" print p let empty = [] - let is_empty t = - match t with - | [] -> true - | _::_ -> false + let is_empty t = match t with [] -> true | _ :: _ -> false let of_list t = t let to_list t = t end -(* As with [Name.t], changing this requires bumping magic numbers. *) -type t = { - name : Name.t; - for_pack_prefix : Prefix.t; - hash : int; -} +(* As with [Name.t], changing [with_prefix] or [t] requires bumping magic + numbers. *) +type with_prefix = + { name : Name.t; + for_pack_prefix : Prefix.t + } + +(* type t = Without_prefix of Name.t [@@unboxed] | With_prefix of with_prefix *) +type t = Obj.t + +(* Some manual inlining is done here to ensure good performance under + Closure. *) + +let for_pack_prefix_and_name t = + let tag = Obj.tag t in + assert (tag = 0 || tag = Obj.string_tag); + if tag <> 0 + then Prefix.empty, Sys.opaque_identity (Obj.obj t : Name.t) + else + let with_prefix = Sys.opaque_identity (Obj.obj t : with_prefix) in + with_prefix.for_pack_prefix, with_prefix.name + +let name t = + let tag = Obj.tag t in + assert (tag = 0 || tag = Obj.string_tag); + if tag <> 0 + then Sys.opaque_identity (Obj.obj t : Name.t) + else + let with_prefix = Sys.opaque_identity (Obj.obj t : with_prefix) in + with_prefix.name + +let for_pack_prefix t = + let tag = Obj.tag t in + assert (tag = 0 || tag = Obj.string_tag); + if tag <> 0 + then Prefix.empty + else + let with_prefix = Sys.opaque_identity (Obj.obj t : with_prefix) in + with_prefix.for_pack_prefix let create for_pack_prefix name = - if not (Prefix.is_empty for_pack_prefix) then begin + let empty_prefix = Prefix.is_empty for_pack_prefix in + if not empty_prefix + then ( Name.check_as_path_component name; ListLabels.iter ~f:Name.check_as_path_component - (for_pack_prefix |> Prefix.to_list) - end; - { name; - for_pack_prefix; - hash = Hashtbl.hash (name, for_pack_prefix) - } + (for_pack_prefix |> Prefix.to_list)); + if empty_prefix + then Sys.opaque_identity (Obj.repr name) + else Sys.opaque_identity (Obj.repr { for_pack_prefix; name }) -let create_child parent name = +let create_child parent name_ = let prefix = - (parent.for_pack_prefix |> Prefix.to_list) @ [ parent.name ] - |> Prefix.of_list + (for_pack_prefix parent |> Prefix.to_list) @ [name parent] |> Prefix.of_list in - create prefix name + create prefix name_ let of_string str = let for_pack_prefix, name = match String.rindex_opt str '.' with | None -> Prefix.empty, Name.of_string str | Some 0 -> - (* See [Name.check_as_path_component]; this allows ".cinaps" as a - compilation unit *) - Prefix.empty, Name.of_string str - | Some _ -> - Misc.fatal_errorf "[of_string] does not parse qualified names" + (* See [Name.check_as_path_component]; this allows ".cinaps" as a + compilation unit *) + Prefix.empty, Name.of_string str + | Some _ -> Misc.fatal_errorf "[of_string] does not parse qualified names" in create for_pack_prefix name @@ -202,67 +246,54 @@ let dummy = create Prefix.empty (Name.of_string "*none*") let predef_exn = create Prefix.empty Name.predef_exn -let name t = t.name - let name_as_string t = name t |> Name.to_string -let for_pack_prefix t = t.for_pack_prefix +let with_for_pack_prefix t for_pack_prefix = create for_pack_prefix (name t) -let with_for_pack_prefix t for_pack_prefix = { t with for_pack_prefix; } - -let is_packed t = not (Prefix.is_empty t.for_pack_prefix) +let is_packed t = not (Prefix.is_empty (for_pack_prefix t)) include Identifiable.Make (struct type nonrec t = t - let compare - ({ name = name1; for_pack_prefix = for_pack_prefix1; - hash = hash1; _} as t1) - ({ name = name2; for_pack_prefix = for_pack_prefix2; - hash = hash2; _} as t2) = - if t1 == t2 then 0 + let compare t1 t2 = + if t1 == t2 + then 0 else - let c = Stdlib.compare hash1 hash2 in - if c <> 0 then c - else - let c = Name.compare name1 name2 in - if c <> 0 then c - else Prefix.compare for_pack_prefix1 for_pack_prefix2 + let for_pack_prefix1, name1 = for_pack_prefix_and_name t1 in + let for_pack_prefix2, name2 = for_pack_prefix_and_name t2 in + let c = Name.compare name1 name2 in + if c <> 0 then c else Prefix.compare for_pack_prefix1 for_pack_prefix2 - let equal x y = - if x == y then true - else compare x y = 0 + let equal x y = if x == y then true else compare x y = 0 let print fmt t = - if Prefix.is_empty t.for_pack_prefix then - Format.fprintf fmt "%a" Name.print t.name - else - Format.fprintf fmt "%a.%a" - Prefix.print t.for_pack_prefix - Name.print t.name + let for_pack_prefix, name = for_pack_prefix_and_name t in + if Prefix.is_empty for_pack_prefix + then Format.fprintf fmt "%a" Name.print name + else Format.fprintf fmt "%a.%a" Prefix.print for_pack_prefix Name.print name let output = output_of_print print - let hash t = t.hash + let hash t = + let for_pack_prefix, name = for_pack_prefix_and_name t in + Hashtbl.hash (Name.hash name, Prefix.hash for_pack_prefix) end) -let full_path t = - (Prefix.to_list t.for_pack_prefix) @ [ t.name ] +let full_path t = Prefix.to_list (for_pack_prefix t) @ [name t] let is_parent t ~child = - List.equal Name.equal (full_path t) (Prefix.to_list child.for_pack_prefix) + List.equal Name.equal (full_path t) (Prefix.to_list (for_pack_prefix child)) let is_strict_prefix list1 ~of_:list2 ~equal = - not (List.equal equal list1 list2) && List.is_prefix list1 ~of_:list2 ~equal + (not (List.equal equal list1 list2)) && List.is_prefix list1 ~of_:list2 ~equal let can_access_by_name t ~accessed_by:me = let my_path = full_path me in (* Criterion 1 in .mli *) let t's_prefix_is_my_ancestor = List.is_prefix - (t.for_pack_prefix |> Prefix.to_list) - ~of_:my_path - ~equal:Name.equal + (for_pack_prefix t |> Prefix.to_list) + ~of_:my_path ~equal:Name.equal in (* Criterion 2 *) let t_is_not_my_strict_ancestor = @@ -272,7 +303,8 @@ let can_access_by_name t ~accessed_by:me = let which_cmx_file desired_comp_unit ~accessed_by : Name.t = let desired_prefix = for_pack_prefix desired_comp_unit in - if Prefix.is_empty desired_prefix then + if Prefix.is_empty desired_prefix + then (* If the unit we're looking for is not in a pack, then the correct .cmx file is the one with the same name as the unit, irrespective of any current pack. *) @@ -281,62 +313,63 @@ let which_cmx_file desired_comp_unit ~accessed_by : Name.t = (* This lines up the full paths as described above. *) let rec match_components ~current ~desired = match current, desired with - | current_name::current, desired_name::desired -> - if Name.equal current_name desired_name then + | current_name :: current, desired_name :: desired -> + if Name.equal current_name desired_name + then (* The full paths are equal up to the current point; keep going. *) match_components ~current ~desired else - (* The paths have diverged. The next component of the desired - path is the .cmx file to load. *) + (* The paths have diverged. The next component of the desired path is + the .cmx file to load. *) desired_name - | [], desired_name::_desired -> - (* The whole of the current unit's full path (including the name of - the unit itself) is now known to be a prefix of the desired unit's - pack *prefix*. This means we must be making a pack. The .cmx - file to load is named after the next component of the desired - unit's path (which may in turn be a pack). *) + | [], desired_name :: _desired -> + (* The whole of the current unit's full path (including the name of the + unit itself) is now known to be a prefix of the desired unit's pack + *prefix*. This means we must be making a pack. The .cmx file to load + is named after the next component of the desired unit's path (which + may in turn be a pack). *) desired_name | [], [] -> (* The paths were equal, so the desired compilation unit is just the current one. *) name desired_comp_unit - | _::_, [] -> - (* The current path is longer than the desired unit's path, which - means we're attempting to go back up the pack hierarchy. This is - an error. *) - Misc.fatal_errorf "Compilation unit@ %a@ is inaccessible when \ - compiling compilation unit@ %a" - print desired_comp_unit - print accessed_by + | _ :: _, [] -> + (* The current path is longer than the desired unit's path, which means + we're attempting to go back up the pack hierarchy. This is an + error. *) + Misc.fatal_errorf + "Compilation unit@ %a@ is inaccessible when compiling compilation \ + unit@ %a" + print desired_comp_unit print accessed_by in match_components ~current:(full_path accessed_by) ~desired:(full_path desired_comp_unit) -let print_name ppf t = - Format.fprintf ppf "%a" Name.print t.name +let print_name ppf t = Format.fprintf ppf "%a" Name.print (name t) let full_path_as_string t = - Format.asprintf "%a" print t + (* We take care not to break sharing when the prefix is empty. However we + can't share in the case where there is a prefix. *) + if Prefix.is_empty (for_pack_prefix t) + then Name.to_string (name t) + else Format.asprintf "%a" print t let to_global_ident_for_bytecode t = Ident.create_persistent (full_path_as_string t) -let print_debug ppf { for_pack_prefix; hash = _; name } = - if Prefix.is_empty for_pack_prefix then - Format.fprintf ppf "@[(\ - @[(id@ %a)@])@]" - Name.print name +let print_debug ppf t = + let name = name t in + let for_pack_prefix = for_pack_prefix t in + if Prefix.is_empty for_pack_prefix + then Format.fprintf ppf "@[(@[(id@ %a)@])@]" Name.print name else - Format.fprintf ppf "@[(\ - @[(for_pack_prefix@ %a)@]@;\ - @[(name@ %a)@]" - Prefix.print for_pack_prefix - Name.print name + Format.fprintf ppf + "@[(@[(for_pack_prefix@ %a)@]@;@[(name@ %a)@]" + Prefix.print for_pack_prefix Name.print name let current = ref None -let set_current t_opt = - current := t_opt +let set_current t_opt = current := t_opt let get_current () = !current @@ -347,7 +380,4 @@ let get_current_exn () = | Some t -> t | None -> Misc.fatal_error "No compilation unit set" -let is_current t = - match !current with - | None -> false - | Some t' -> equal t t' +let is_current t = match !current with None -> false | Some t' -> equal t t' diff --git a/utils/compilation_unit.mli b/utils/compilation_unit.mli index f347891b4aff..ef25d0063013 100644 --- a/utils/compilation_unit.mli +++ b/utils/compilation_unit.mli @@ -18,10 +18,9 @@ prefixes. By "compilation unit" we mean the code and data associated with the - compilation of a single .ml source file: that is to say, file-level - entities having OCaml semantics. The notion neither includes the special - "startup" files nor external libraries. -*) + compilation of a single .ml source file: that is to say, file-level entities + having OCaml semantics. The notion neither includes the special "startup" + files nor external libraries. *) [@@@ocaml.warning "+a-9-40-41-42"] @@ -191,7 +190,11 @@ type error = private exception Error of error val set_current : t option -> unit + val get_current : unit -> t option + val get_current_or_dummy : unit -> t + val get_current_exn : unit -> t + val is_current : t -> bool diff --git a/utils/import_info.ml b/utils/import_info.ml new file mode 100644 index 000000000000..3efc610c1fe4 --- /dev/null +++ b/utils/import_info.ml @@ -0,0 +1,66 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell, Jane Street UK Partnership LLP *) +(* *) +(* Copyright 2022 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module CU = Compilation_unit + +type t = + | Normal of CU.t * Digest.t + | Normal_no_crc of CU.t + | Other of CU.Name.t * (CU.t * Digest.t) option + +(* CR xclerc: Maybe introduce Other_no_crc to flatten the option *) + +let create cu_name ~crc_with_unit = + match crc_with_unit with + | None -> Other (cu_name, None) + | Some (cu, crc) -> + (* For the moment be conservative and only use the [Normal] constructor when + there is no pack prefix at all. *) + if CU.Prefix.is_empty (CU.for_pack_prefix cu) + && CU.Name.equal (CU.name cu) cu_name + then Normal (cu, crc) + else Other (cu_name, Some (cu, crc)) + +let create_normal cu ~crc = + match crc with Some crc -> Normal (cu, crc) | None -> Normal_no_crc cu + +let name t = + match t with + | Normal (cu, _) | Normal_no_crc cu -> CU.name cu + | Other (name, _) -> name + +let cu t = + match t with + | Normal (cu, _) | Normal_no_crc cu | Other (_, Some (cu, _)) -> cu + | Other (name, None) -> + Misc.fatal_errorf + "Cannot extract [Compilation_unit.t] from [Import_info.t] (for unit %a) \ + that never received it" + CU.Name.print name + +let crc t = + match t with + | Normal (_, crc) -> Some crc + | Normal_no_crc _ | Other (_, None) -> None + | Other (_, Some (_, crc)) -> Some crc + +let crc_with_unit t = + match t with + | Normal (cu, crc) -> Some (cu, crc) + | Normal_no_crc _ | Other (_, None) -> None + | Other (_, some_cu_and_crc) -> some_cu_and_crc + +let has_name t ~name:name' = CU.Name.equal (name t) name' + +let dummy = Other (CU.Name.dummy, None) diff --git a/utils/import_info.mli b/utils/import_info.mli new file mode 100644 index 000000000000..845e5f086ff6 --- /dev/null +++ b/utils/import_info.mli @@ -0,0 +1,50 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell, Jane Street UK Partnership LLP *) +(* *) +(* Copyright 2022 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module CU = Compilation_unit + +(* CR mshinwell: maybe there should be a phantom type allowing to distinguish + the .cmx case from the others. Unclear it's worth it. + + xclerc: I also wonder whether it could be useful to have an abstract Array.t + in this module. Indeed the import infos are now mutable; we could hide the + mutability behind an abstract type. I reckon we use only a handful of array + operations on such values, so it should not be too bad. If that happens, it + should probably be in another PR. + + (We could also wait for immutable arrays.) *) + +(* CR mshinwell/xclerc: maybe the reading and writing code should be put in + here, or somewhere alongside, rather than being duplicated around the + tree. *) + +type t + +val create : CU.Name.t -> crc_with_unit:(CU.t * string) option -> t + +val create_normal : CU.t -> crc:string option -> t + +val name : t -> CU.Name.t + +(** This function will cause a fatal error if a [CU.t] was not provided when the + supplied value of type [t] was created. *) +val cu : t -> CU.t + +val crc : t -> string option + +val crc_with_unit : t -> (CU.t * string) option + +val has_name : t -> name:CU.Name.t -> bool + +val dummy : t