diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index 4d64457fb36..41931bdcfcd 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -37,8 +37,7 @@ exception Error of error (* Consistency check between interfaces and implementations *) -module Cmi_consistbl = - Consistbl.Make (CU.Name) (Import_info.Intf.Nonalias.Kind) +module Cmi_consistbl = Consistbl.Make (CU.Name) (CU) let crc_interfaces = Cmi_consistbl.create () let interfaces = ref ([] : CU.Name.t list) @@ -59,12 +58,12 @@ let check_consistency file_name unit crc = Array.iter (fun import -> let name = Import_info.name import in - let info = Import_info.Intf.info import in + let crco = Import_info.crc_with_unit import in interfaces := name :: !interfaces; - match info with + match crco with None -> () - | Some (kind, crc) -> - Cmi_consistbl.check crc_interfaces name kind crc file_name) + | Some (full_name, crc) -> + Cmi_consistbl.check crc_interfaces name full_name crc file_name) unit.ui_imports_cmi with Cmi_consistbl.Inconsistency { unit_name = name; @@ -103,7 +102,7 @@ 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.Intf.create name crc_with_unit) + Import_info.create name ~crc_with_unit) let extract_crc_implementations () = Cmx_consistbl.extract !implementations crc_implementations @@ -245,7 +244,7 @@ let make_globals_map units_list ~crc_interfaces = let crc_interfaces = crc_interfaces |> List.map (fun import -> - Import_info.name import, Import_info.crc import) + Import_info.name import, Import_info.crc_with_unit import) |> CU.Name.Tbl.of_list in let defined = @@ -253,6 +252,7 @@ let make_globals_map units_list ~crc_interfaces = let name = CU.name unit.ui_unit in let intf_crc = CU.Name.Tbl.find crc_interfaces name + |> Option.map (fun (_unit, crc) -> crc) in CU.Name.Tbl.remove crc_interfaces name; let syms = List.map Symbol.for_compilation_unit unit.ui_defines in @@ -260,6 +260,7 @@ let make_globals_map units_list ~crc_interfaces = units_list in CU.Name.Tbl.fold (fun name intf acc -> + let intf = Option.map (fun (_unit, crc) -> crc) intf in (assume_no_prefix name, intf, None, []) :: acc) crc_interfaces defined diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index aeb54199fb3..4e5e0e0c948 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -184,7 +184,7 @@ let scan_file obj_name tolink = (* Consistency check between interfaces *) -module Consistbl = Consistbl.Make (CU.Name) (Import_info.Intf.Nonalias.Kind) +module Consistbl = Consistbl.Make (CU.Name) (Compilation_unit) let crc_interfaces = Consistbl.create () let interfaces = ref ([] : CU.Name.t list) @@ -200,12 +200,12 @@ let check_consistency file_name cu = Array.iter (fun import -> let name = Import_info.name import in - let info = Import_info.Intf.info import in + let crco = Import_info.crc_with_unit import in interfaces := name :: !interfaces; - match info with + match crco with None -> () - | Some (kind, crc) -> - Consistbl.check crc_interfaces name kind crc file_name) + | Some (full_name, crc) -> + Consistbl.check crc_interfaces name full_name crc file_name) cu.cu_imports with Consistbl.Inconsistency { unit_name = name; @@ -220,7 +220,7 @@ let check_consistency file_name cu = let extract_crc_interfaces () = Consistbl.extract !interfaces crc_interfaces |> List.map (fun (name, crc_with_unit) -> - Import_info.Intf.create name crc_with_unit) + Import_info.create name ~crc_with_unit) let clear_crc_interfaces () = Consistbl.clear crc_interfaces; diff --git a/driver/compile_common.ml b/driver/compile_common.ml index babf71d24ae..fa64c624ed1 100644 --- a/driver/compile_common.ml +++ b/driver/compile_common.ml @@ -83,16 +83,15 @@ let typecheck_intf info ast = let emit_signature info ast tsg = let sg = - let name = Compilation_unit.name info.module_name in let kind : Cmi_format.kind = if !Clflags.as_parameter then Parameter else - Normal { cmi_impl = info.module_name } + Normal in let alerts = Builtin_attributes.alerts_of_sig ast in Env.save_signature ~alerts tsg.Typedtree.sig_type - name kind (info.output_prefix ^ ".cmi") + info.module_name kind (info.output_prefix ^ ".cmi") in Typemod.save_signature info.module_name tsg info.output_prefix info.source_file info.env sg diff --git a/file_formats/cmi_format.ml b/file_formats/cmi_format.ml index 1e0b86aa173..b135c6a1ee5 100644 --- a/file_formats/cmi_format.ml +++ b/file_formats/cmi_format.ml @@ -21,9 +21,7 @@ type pers_flags = | Opaque type kind = - | Normal of { - cmi_impl : Compilation_unit.t; - } + | Normal | Parameter type error = @@ -60,13 +58,13 @@ module Serialized = Types.Make_wrapped(struct type 'a t = int end) type crcs = Import_info.t array (* smaller on disk than using a list *) type flags = pers_flags list type header = { - header_name : Compilation_unit.Name.t; + header_name : Compilation_unit.t; header_kind : kind; header_sign : Serialized.signature; } type 'sg cmi_infos_generic = { - cmi_name : Compilation_unit.Name.t; + cmi_name : Compilation_unit.t; cmi_kind : kind; cmi_sign : 'sg; cmi_crcs : crcs; @@ -194,14 +192,10 @@ let output_cmi filename oc cmi = (* BACKPORT END *) flush oc; let crc = Digest.file filename in - let my_info = - match cmi.cmi_kind with - | Normal { cmi_impl } -> - Import_info.Intf.create_normal cmi.cmi_name cmi_impl ~crc - | Parameter -> - Import_info.Intf.create_parameter cmi.cmi_name ~crc + let crcs = + Array.append [| Import_info.create_normal cmi.cmi_name ~crc:(Some crc) |] + cmi.cmi_crcs in - let crcs = Array.append [| my_info |] cmi.cmi_crcs in output_value oc (crcs : crcs); output_value oc (cmi.cmi_flags : flags); crc diff --git a/file_formats/cmi_format.mli b/file_formats/cmi_format.mli index 72fef143c25..87df56780ab 100644 --- a/file_formats/cmi_format.mli +++ b/file_formats/cmi_format.mli @@ -21,13 +21,11 @@ type pers_flags = | Opaque type kind = - | Normal of { - cmi_impl : Compilation_unit.t; - } + | Normal | Parameter type 'sg cmi_infos_generic = { - cmi_name : Compilation_unit.Name.t; + cmi_name : Compilation_unit.t; cmi_kind : kind; cmi_sign : 'sg; cmi_crcs : Import_info.t array; diff --git a/testsuite/tests/templates/basic/bad_param_impl.ml b/testsuite/tests/templates/basic/bad_param_impl.ml index c15a617d29b..0ad3ce763eb 100644 --- a/testsuite/tests/templates/basic/bad_param_impl.ml +++ b/testsuite/tests/templates/basic/bad_param_impl.ml @@ -9,8 +9,6 @@ ocamlc_byte_exit_status = "2"; compiler_output = "bad_param_impl.output"; ocamlc.byte; - reason = "error broken, will be fixed by #1764"; - skip; compiler_reference = "bad_param_impl.reference"; check-ocamlc.byte-output; *) diff --git a/testsuite/tests/templates/basic/test.ml b/testsuite/tests/templates/basic/test.ml index b4620b86118..d6ed4eddc58 100644 --- a/testsuite/tests/templates/basic/test.ml +++ b/testsuite/tests/templates/basic/test.ml @@ -8,8 +8,6 @@ compiler_output = "bad_ref_direct.output"; ocamlc_byte_exit_status = "2"; ocamlc.byte; - reason = "correct error message not yet implemented"; - skip; compiler_reference = "bad_ref_direct.reference"; check-ocamlc.byte-output; *) diff --git a/tools/objinfo.ml b/tools/objinfo.ml index 1cc5013ae5f..5e827323d8a 100644 --- a/tools/objinfo.ml +++ b/tools/objinfo.ml @@ -99,10 +99,10 @@ let print_cma_infos (lib : Cmo_format.library) = let print_cmi_infos name crcs kind = if not !quiet then begin let open Cmi_format in - printf "Unit name: %a\n" Compilation_unit.Name.output name; + printf "Unit name: %a\n" Compilation_unit.output name; let is_param = match kind with - | Normal _ -> false + | Normal -> false | Parameter -> true in printf "Is parameter: %s\n" (if is_param then "YES" else "no"); diff --git a/tools/ocamlcmt.ml b/tools/ocamlcmt.ml index 938acf2120b..31169a1877d 100644 --- a/tools/ocamlcmt.ml +++ b/tools/ocamlcmt.ml @@ -91,7 +91,7 @@ let print_info cmt = let imports = let imports = Array.map (fun import -> - Import_info.name import, Import_info.crc import) + Import_info.name import, Import_info.crc_with_unit import) cmt.cmt_imports in Array.sort compare_imports imports; @@ -101,7 +101,7 @@ let print_info cmt = let crc = match crco with None -> dummy_crc - | Some crc -> Digest.to_hex crc + | Some (_unit, crc) -> Digest.to_hex crc in Printf.fprintf oc "import: %a %s\n" Compilation_unit.Name.output name crc; ) imports; diff --git a/typing/env.ml b/typing/env.ml index 7240e94ed20..c58f25de945 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -954,11 +954,7 @@ let components_of_module ~alerts ~uid env ps path addr mty shape = } let read_sign_of_cmi { Persistent_env.Persistent_signature.cmi; _ } = - let name = - match cmi.cmi_kind with - | Normal { cmi_impl } -> cmi_impl - | Parameter -> Misc.fatal_error "Unsupported import of parameter module" - in + let name = cmi.cmi_name in let sign = cmi.cmi_sign in let flags = cmi.cmi_flags in let id = Ident.create_persistent (Compilation_unit.name_as_string name) in @@ -2647,7 +2643,7 @@ let open_signature (* Read a signature from a file *) let read_signature modname filename ~add_binding = let mda = - read_pers_mod modname filename ~add_binding + read_pers_mod (Compilation_unit.name modname) filename ~add_binding in let md = Subst.Lazy.force_module_decl mda.mda_declaration in match md.md_type with diff --git a/typing/env.mli b/typing/env.mli index 1e1cfa42561..1a4835ed800 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -463,16 +463,16 @@ val get_unit_name: unit -> Compilation_unit.t option (* Read, save a signature to/from a file *) val read_signature: - Compilation_unit.Name.t -> filepath -> add_binding:bool -> signature + Compilation_unit.t -> filepath -> add_binding:bool -> signature (* Arguments: module name, file name, [add_binding] flag. Results: signature. If [add_binding] is true, creates an entry for the module in the environment. *) val save_signature: - alerts:alerts -> signature -> Compilation_unit.Name.t -> Cmi_format.kind + alerts:alerts -> signature -> Compilation_unit.t -> Cmi_format.kind -> filepath -> Cmi_format.cmi_infos_lazy (* Arguments: signature, module name, module kind, file name. *) val save_signature_with_imports: - alerts:alerts -> signature -> Compilation_unit.Name.t -> Cmi_format.kind + alerts:alerts -> signature -> Compilation_unit.t -> Cmi_format.kind -> filepath -> Import_info.t array -> Cmi_format.cmi_infos_lazy (* Arguments: signature, module name, module kind, file name, imported units with their CRCs. *) diff --git a/typing/persistent_env.ml b/typing/persistent_env.ml index af075023b82..fa07500ab99 100644 --- a/typing/persistent_env.ml +++ b/typing/persistent_env.ml @@ -20,15 +20,15 @@ open Misc open Cmi_format module CU = Compilation_unit -module Consistbl_data = Import_info.Intf.Nonalias.Kind -module Consistbl = Consistbl.Make (CU.Name) (Consistbl_data) +module Consistbl = Consistbl.Make (CU.Name) (CU) let add_delayed_check_forward = ref (fun _ -> assert false) type error = | Illegal_renaming of CU.Name.t * CU.Name.t * filepath | Inconsistent_import of CU.Name.t * filepath * filepath - | Need_recursive_types of CU.Name.t + | Need_recursive_types of CU.t + | Inconsistent_package_declaration of CU.t * filepath | Inconsistent_package_declaration_between_imports of filepath * CU.t * CU.t | Direct_reference_from_wrong_package of @@ -62,9 +62,11 @@ type can_load_cmis = | Cannot_load_cmis of Lazy_backtrack.log type pers_struct = { + ps_name: CU.t; ps_is_param: bool; ps_crcs: Import_info.t array; ps_filename: string; + ps_flags: pers_flags list; ps_visibility: Load_path.visibility; } @@ -147,13 +149,13 @@ let register_parameter_import ({param_imports; _} as penv) import = let import_crcs penv ~source crcs = let {crc_units; _} = penv in let import_crc import_info = - let name = Import_info.Intf.name import_info in - let info = Import_info.Intf.info import_info in - match info with + let name = Import_info.name import_info in + let crco = Import_info.crc_with_unit import_info in + match crco with | None -> () - | Some (kind, crc) -> + | Some (unit, crc) -> add_import penv name; - Consistbl.check crc_units name kind crc source + Consistbl.check crc_units name unit crc source in Array.iter import_crc crcs let check_consistency penv ps = @@ -162,16 +164,13 @@ let check_consistency penv ps = unit_name = name; inconsistent_source = source; original_source = auth; - inconsistent_data = source_kind; - original_data = auth_kind; + inconsistent_data = source_unit; + original_data = auth_unit; } -> - match source_kind, auth_kind with - | Normal source_unit, Normal auth_unit - when not (CU.equal source_unit auth_unit) -> - error (Inconsistent_package_declaration_between_imports( - ps.ps_filename, auth_unit, source_unit)) - | (Normal _ | Parameter), _ -> - error (Inconsistent_import(name, auth, source)) + 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)) let is_registered_parameter_import {param_imports; _} import = CU.Name.Set.mem import !param_imports @@ -199,62 +198,64 @@ let fold {persistent_structures; _} f x = (* Reading persistent structures from .cmi files *) -let save_pers_struct penv crc modname impl flags filename = +let save_pers_struct penv crc comp_unit flags filename = let {crc_units; _} = penv in + let modname = CU.name comp_unit in List.iter (function | Rectypes -> () | Alerts _ -> () | Opaque -> register_import_as_opaque penv modname) flags; - Consistbl.check crc_units modname impl crc filename; + Consistbl.check crc_units modname comp_unit crc filename; add_import penv modname let process_pers_struct penv check modname pers_sig = let { Persistent_signature.filename; cmi; visibility } = pers_sig in - let found_name = cmi.cmi_name in + let name = cmi.cmi_name in let kind = cmi.cmi_kind in let crcs = cmi.cmi_crcs in let flags = cmi.cmi_flags in let is_param = match kind with - | Normal _ -> false + | Normal -> false | Parameter -> true in - let ps = { ps_is_param = is_param; + let ps = { ps_name = name; + ps_is_param = is_param; ps_crcs = crcs; ps_filename = filename; + ps_flags = flags; ps_visibility = visibility; } in + 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 | Rectypes -> if not !Clflags.recursive_types then - error (Need_recursive_types(modname)) + error (Need_recursive_types(ps.ps_name)) | Alerts _ -> () | Opaque -> register_import_as_opaque penv modname) - flags; + ps.ps_flags; if check then check_consistency penv ps; - begin match kind, CU.get_current () with - | Normal { cmi_impl = imported_unit }, Some current_unit -> + begin match CU.get_current () with + | Some current_unit -> let access_allowed = - CU.can_access_by_name imported_unit ~accessed_by:current_unit + CU.can_access_by_name name ~accessed_by:current_unit in if not access_allowed then let prefix = CU.for_pack_prefix current_unit in - error (Direct_reference_from_wrong_package (imported_unit, filename, prefix)); - | _, _ -> () + error (Direct_reference_from_wrong_package (name, filename, prefix)); + | None -> () end; begin match is_param, is_registered_parameter_import penv modname with | true, false -> - begin match CU.get_current () with - | Some current_unit when CU.Name.equal modname (CU.name current_unit) -> - error (Cannot_implement_parameter (modname, filename)) - | _ -> - error (Illegal_import_of_parameter(modname, filename)) - end + if CU.is_current name then + error (Cannot_implement_parameter (modname, filename)) + else + error (Illegal_import_of_parameter(modname, filename)) | false, true -> error (Not_compiled_as_parameter(modname, filename)) | true, true @@ -337,7 +338,8 @@ let check_pers_struct ~allow_hidden penv f ~loc name = | Need_recursive_types name -> Format.asprintf "%a uses recursive types" - CU.Name.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" @@ -402,7 +404,8 @@ let imports {imported_units; crc_units; _} = Consistbl.extract (CU.Name.Set.elements !imported_units) crc_units in - List.map (fun (cu_name, spec) -> Import_info.Intf.create cu_name spec) + List.map (fun (cu_name, crc_with_unit) -> + Import_info.create cu_name ~crc_with_unit) imports let looked_up {persistent_structures; _} modname = @@ -436,7 +439,6 @@ let save_cmi penv psig = Misc.try_finally (fun () -> let { cmi_name = modname; - cmi_kind = kind; cmi_sign = _; cmi_crcs = _; cmi_flags = flags; @@ -447,12 +449,7 @@ let save_cmi penv psig = (fun temp_filename oc -> output_cmi temp_filename oc cmi) in (* Enter signature in consistbl so that imports() will also return its crc *) - let data : Import_info.Intf.Nonalias.Kind.t = - match kind with - | Normal { cmi_impl } -> Normal cmi_impl - | Parameter -> Parameter - in - save_pers_struct penv crc modname data flags filename + save_pers_struct penv crc modname flags filename ) ~exceptionally:(fun () -> remove_file filename) @@ -473,14 +470,13 @@ let report_error ppf = | Need_recursive_types(import) -> fprintf ppf "@[Invalid import of %a, which uses recursive types.@ %s@]" - CU.Name.print import + CU.print import "The compilation flag -rectypes is required" - | Inconsistent_package_declaration_between_imports (filename, unit1, unit2) -> + | Inconsistent_package_declaration(intf_package, intf_filename) -> fprintf ppf - "@[The file %s@ is imported both as %a@ and as %a.@]" - filename - CU.print unit1 - CU.print unit2 + "@[The interface %a@ is compiled for package %s.@ %s@]" + CU.print intf_package intf_filename + "The compilation flag -for-pack with the same package is required" | Illegal_import_of_parameter(modname, filename) -> fprintf ppf "@[The file %a@ contains the interface of a parameter.@ \ @@ -494,6 +490,12 @@ let report_error ppf = was not compiled with -as-parameter.@]" CU.Name.print modname Location.print_filename filename + | Inconsistent_package_declaration_between_imports (filename, unit1, unit2) -> + fprintf ppf + "@[The file %s@ is imported both as %a@ and as %a.@]" + filename + 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]" diff --git a/typing/persistent_env.mli b/typing/persistent_env.mli index 3fc9258a4d1..54ccffcd60e 100644 --- a/typing/persistent_env.mli +++ b/typing/persistent_env.mli @@ -16,18 +16,15 @@ open Misc -module Consistbl_data : sig - type t -end - module Consistbl : module type of struct - include Consistbl.Make (Compilation_unit.Name) (Consistbl_data) + include Consistbl.Make (Compilation_unit.Name) (Compilation_unit) end 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.Name.t + | Need_recursive_types of Compilation_unit.t + | Inconsistent_package_declaration of Compilation_unit.t * filepath | Inconsistent_package_declaration_between_imports of filepath * Compilation_unit.t * Compilation_unit.t | Direct_reference_from_wrong_package of @@ -108,7 +105,7 @@ val is_imported_opaque : 'a t -> Compilation_unit.Name.t -> bool val register_import_as_opaque : 'a t -> Compilation_unit.Name.t -> unit val make_cmi : 'a t - -> Compilation_unit.Name.t + -> Compilation_unit.t -> Cmi_format.kind -> Subst.Lazy.signature -> alerts diff --git a/typing/typemod.ml b/typing/typemod.ml index b1fbf9bd977..a757935bc50 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -3427,9 +3427,8 @@ let type_implementation ~sourcefile outputprefix modulename initial_env ast = Interface_not_compiled sourceintf))) | Some cmi_file -> cmi_file in - let import = Compilation_unit.name modulename in let dclsig = - Env.read_signature import intf_file ~add_binding:false + Env.read_signature modulename intf_file ~add_binding:false in let coercion, shape = Profile.record_call "check_sig" (fun () -> @@ -3475,14 +3474,11 @@ let type_implementation ~sourcefile outputprefix modulename initial_env ast = let shape = Shape_reduce.local_reduce Env.empty shape in if not !Clflags.dont_write_files then begin let alerts = Builtin_attributes.alerts_of_str ast in - let name = Compilation_unit.name modulename in - let kind = - Cmi_format.Normal { cmi_impl = modulename } - in + let kind = Cmi_format.Normal in let cmi = Profile.record_call "save_cmi" (fun () -> Env.save_signature ~alerts - simple_sg name kind (outputprefix ^ ".cmi")) + simple_sg modulename kind (outputprefix ^ ".cmi")) in Profile.record_call "save_cmt" (fun () -> let annots = Cmt_format.Implementation str in @@ -3583,13 +3579,13 @@ let package_units initial_env objfiles cmifile modulename = in let modname = Compilation_unit.create_child modulename unit in let sg = - Env.read_signature unit (pref ^ ".cmi") ~add_binding:false in + Env.read_signature modname (pref ^ ".cmi") ~add_binding:false in if Filename.check_suffix f ".cmi" && not(Mtype.no_code_needed_sig (Lazy.force Env.initial) sg) then raise(Error(Location.none, Env.empty, Implementation_is_required f)); Compilation_unit.name modname, - Env.read_signature unit (pref ^ ".cmi") ~add_binding:false) + Env.read_signature modname (pref ^ ".cmi") ~add_binding:false) objfiles in (* Compute signature of packaged unit *) Ident.reinit(); @@ -3612,8 +3608,7 @@ let package_units initial_env objfiles cmifile modulename = raise(Error(Location.in_file mlifile, Env.empty, Interface_not_compiled mlifile)) end; - let name = Compilation_unit.name modulename in - let dclsig = Env.read_signature name cmifile ~add_binding:false in + let dclsig = Env.read_signature modulename cmifile ~add_binding:false in let cc, _shape = Includemod.compunit initial_env ~mark:Mark_both "(obtained by packing)" sg mlifile dclsig shape @@ -3633,11 +3628,11 @@ let package_units initial_env objfiles cmifile modulename = (Env.imports()) in (* Write packaged signature *) if not !Clflags.dont_write_files then begin - let name = Compilation_unit.name modulename in - let kind = Cmi_format.Normal { cmi_impl = modulename } in + let kind = Cmi_format.Normal in let cmi = Env.save_signature_with_imports ~alerts:Misc.Stdlib.String.Map.empty - sg name kind (prefix ^ ".cmi") (Array.of_list imports) + sg modulename kind + (prefix ^ ".cmi") (Array.of_list imports) in let sign = Subst.Lazy.force_signature cmi.Cmi_format.cmi_sign in Cmt_format.save_cmt (prefix ^ ".cmt") modulename diff --git a/utils/import_info.ml b/utils/import_info.ml index a3bc2b0a8b0..3efc610c1fe 100644 --- a/utils/import_info.ml +++ b/utils/import_info.ml @@ -14,44 +14,36 @@ module CU = Compilation_unit -type intf = - | Normal of CU.Name.t * CU.t * Digest.t - | Alias of CU.Name.t - | Parameter of CU.Name.t * Digest.t - -type impl = - | Loaded of CU.t * Digest.t - | Unloaded of CU.t - -(* CR-soon lmaurer: This combined type should go away soon, since each [t] is - actually statically known to be either an [intf] or an [impl] (see PR - #1933) *) type t = - | Intf of intf - | Impl of impl + | 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 = - (* This creates an [Intf] just to be minimally restrictive. Any caller that - cares should use the [Impl] API. *) match crc_with_unit with - | None -> Intf (Alias cu_name) - | Some (cu, crc) -> Intf (Normal (cu_name, cu, crc)) + | 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 -> Impl (Loaded (cu, crc)) - | None -> Impl (Unloaded cu) + match crc with Some crc -> Normal (cu, crc) | None -> Normal_no_crc cu let name t = match t with - | Impl (Loaded (cu, _) | Unloaded cu) -> CU.name cu - | Intf (Normal (name, _, _) | Alias name | Parameter (name, _)) -> name + | Normal (cu, _) | Normal_no_crc cu -> CU.name cu + | Other (name, _) -> name let cu t = match t with - | Intf (Normal (_, cu, _)) -> cu - | Impl (Loaded (cu, _) | Unloaded cu) -> cu - | Intf (Alias name | Parameter (name, _)) -> + | 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" @@ -59,102 +51,16 @@ let cu t = let crc t = match t with - | Intf (Normal (_, _, crc) | Parameter (_, crc)) -> Some crc - | Intf (Alias _) -> None - | Impl (Loaded (_, crc)) -> Some crc - | Impl (Unloaded _) -> None - -let has_name t ~name:name' = CU.Name.equal (name t) name' - -let dummy = Intf (Alias CU.Name.dummy) - -module Intf = struct - (* Currently this is the same type as [Impl.t] but this will change (see PR - #1746). *) - type nonrec t = t - - let create_normal name cu ~crc = - if not (CU.Name.equal (CU.name cu) name) - then - Misc.fatal_errorf - "@[Mismatched import name and compilation unit:@ %a != %a@]" - CU.Name.print name CU.print cu; - Intf (Normal (name, cu, crc)) - - let create_alias name = Intf (Alias name) - - let create_parameter name ~crc = Intf (Parameter (name, crc)) - - module Nonalias = struct - module Kind = struct - type t = - | Normal of CU.t - | Parameter - end - - type t = Kind.t * Digest.t - end - - let create name nonalias = - match (nonalias : Nonalias.t option) with - | None -> create_alias name - | Some (Normal cu, crc) -> create_normal name cu ~crc - | Some (Parameter, crc) -> create_parameter name ~crc - - let expect_intf t = - match t with - | Intf intf -> intf - | Impl (Loaded (cu, _) | Unloaded cu) -> - Misc.fatal_errorf "Expected an [Import_info.Impl.t] but found %a" CU.print - cu + | Normal (_, crc) -> Some crc + | Normal_no_crc _ | Other (_, None) -> None + | Other (_, Some (_, crc)) -> Some crc - let name t = - match expect_intf t with - | Normal (name, _, _) | Alias name | Parameter (name, _) -> name - - let info t : Nonalias.t option = - match expect_intf t with - | Normal (_, cu, crc) -> Some (Normal cu, crc) - | Parameter (_, crc) -> Some (Parameter, crc) - | Alias _ -> None - - let crc t = - match expect_intf t with - | Normal (_, _, crc) | Parameter (_, crc) -> Some crc - | Alias _ -> None - - let has_name t ~name:name' = CU.Name.equal (name t) name' - - let dummy = dummy -end - -module Impl = struct - (* Currently this is the same type as [Intf.t] but this will change (see PR - #1746). *) - type nonrec t = t - - let create_loaded cu ~crc = Impl (Loaded (cu, crc)) - - let create_unloaded cu = Impl (Unloaded cu) - - let create cu ~crc = - match crc with - | Some crc -> create_loaded cu ~crc - | None -> create_unloaded cu - - let expect_impl t = - match t with - | Impl impl -> impl - | Intf (Normal (name, _, _) | Alias name | Parameter (name, _)) -> - Misc.fatal_errorf "Expected an [Import_info.Intf.t] but found %a" - CU.Name.print name - - let cu t = match expect_impl t with Loaded (cu, _) | Unloaded cu -> cu - - let name t = CU.name (cu t) +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 crc t = - match expect_impl t with Loaded (_, crc) -> Some crc | Unloaded _ -> None +let has_name t ~name:name' = CU.Name.equal (name t) name' - let dummy = Impl (Unloaded CU.dummy) -end +let dummy = Other (CU.Name.dummy, None) diff --git a/utils/import_info.mli b/utils/import_info.mli index 61154054508..845e5f086ff 100644 --- a/utils/import_info.mli +++ b/utils/import_info.mli @@ -12,7 +12,7 @@ (* *) (**************************************************************************) -module CU := Compilation_unit +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. @@ -29,8 +29,6 @@ module CU := Compilation_unit here, or somewhere alongside, rather than being duplicated around the tree. *) -(** Either an interface (.cmi) or implementation (.cmo/x) import. Should be - avoided in new code, in preference to [Intf.t] or [Impl.t]. *) type t val create : CU.Name.t -> crc_with_unit:(CU.t * string) option -> t @@ -45,72 +43,8 @@ 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 - -(** The preferred API to use for interface imports. An interface import might be - a parameter, in which case it has a CRC but no [CU.t] (since a [CU.t] is for - an implementation). *) -module Intf : sig - type nonrec t = t - - val create_normal : CU.Name.t -> CU.t -> crc:Digest.t -> t - - val create_alias : CU.Name.t -> t - - val create_parameter : CU.Name.t -> crc:Digest.t -> t - - module Nonalias : sig - module Kind : sig - type t = - | Normal of CU.t - | Parameter - end - - (** The "non-alias part" of the import info for an interface. An [Intf.t] is - equivalent to a [CU.Name.t * Nonalias.t option] (use [create], [name], and [spec] - to convert back and forth). *) - type t = Kind.t * Digest.t - end - - (** [create name nonalias] is [create_normal name cu crc] if [nonalias] is [Some (Normal - cu, crc)], [create_parameter name crc] if [nonalias] is [Some (Parameter, crc)], and - [create_alias] if [nonalias] is [None]. Useful when [nonalias] is coming out of - [Consistbl]. *) - val create : CU.Name.t -> Nonalias.t option -> t - - val name : t -> CU.Name.t - - val info : t -> Nonalias.t option - - val crc : t -> Digest.t option - - val has_name : t -> name:CU.Name.t -> bool - - val dummy : t -end - -module Impl : sig - type nonrec t = t - - (** The import info for an implementation we depend on and whose .cmx we actually - loaded. *) - val create_loaded : CU.t -> crc:Digest.t -> t - - (** The import info for an implementation we depend on but for which we never loaded a - .cmx (and thus have no CRC for). *) - val create_unloaded : CU.t -> t - - (** [create cu ~crc] is [create_loaded] if [crc] is [Some] and [create_unloaded] if - [crc] is [None]. Useful when [crc] is coming out of [Consistbl]. *) - val create : CU.t -> crc:Digest.t option -> t - - val name : t -> CU.Name.t - - val cu : t -> CU.t - - val crc : t -> Digest.t option - - val dummy : t -end