From 595f75e58b72fc833aa64d831a1054b49c00238e Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Wed, 23 Apr 2025 16:50:03 +0100 Subject: [PATCH 1/3] Add `kind` to `Unit_info.t` --- driver/compile.ml | 3 ++- driver/compile_common.ml | 4 ++-- driver/compile_common.mli | 1 + driver/optcompile.ml | 3 ++- parsing/unit_info.ml | 7 +++++-- parsing/unit_info.mli | 10 ++++++++-- 6 files changed, 20 insertions(+), 8 deletions(-) diff --git a/driver/compile.ml b/driver/compile.ml index 8aabea0df7a..b985f1dbcb6 100644 --- a/driver/compile.ml +++ b/driver/compile.ml @@ -23,7 +23,7 @@ let with_info = let interface ~source_file ~output_prefix = with_info ~source_file ~output_prefix ~dump_ext:"cmi" - ~compilation_unit:Inferred_from_output_prefix + ~compilation_unit:Inferred_from_output_prefix ~kind:Intf @@ fun info -> Compile_common.interface ~hook_parse_tree:(fun _ -> ()) @@ -102,6 +102,7 @@ let implementation_aux ~start_from ~source_file ~output_prefix ~keep_symbol_tables:_ ~(compilation_unit : Compile_common.compilation_unit_or_inferred) = with_info ~source_file ~output_prefix ~dump_ext:"cmo" ~compilation_unit + ~kind:Impl @@ fun info -> match start_from with | Parsing -> diff --git a/driver/compile_common.ml b/driver/compile_common.ml index ed200f90e85..ad035780b12 100644 --- a/driver/compile_common.ml +++ b/driver/compile_common.ml @@ -29,10 +29,10 @@ type compilation_unit_or_inferred = | Inferred_from_output_prefix let with_info ~native ~tool_name ~source_file ~output_prefix - ~compilation_unit ~dump_ext k = + ~compilation_unit ~kind ~dump_ext k = Compmisc.init_path (); Compmisc.init_parameters (); - let target = Unit_info.make ~source_file output_prefix in + let target = Unit_info.make ~source_file kind output_prefix in let compilation_unit = match compilation_unit with | Exactly compilation_unit -> compilation_unit diff --git a/driver/compile_common.mli b/driver/compile_common.mli index 3a3f756f8f8..82944b8f5f6 100644 --- a/driver/compile_common.mli +++ b/driver/compile_common.mli @@ -36,6 +36,7 @@ val with_info : source_file:string -> output_prefix:string -> compilation_unit:compilation_unit_or_inferred -> + kind:Unit_info.intf_or_impl -> dump_ext:string -> (info -> 'a) -> 'a (** [with_info ~native ~tool_name ~source_file ~output_prefix ~dump_ext k] diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 569a53ff941..d05e573a807 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -24,7 +24,7 @@ let with_info = Compile_common.with_info ~native:true ~tool_name let interface ~source_file ~output_prefix = with_info ~source_file ~output_prefix ~dump_ext:"cmi" - ~compilation_unit:Inferred_from_output_prefix + ~compilation_unit:Inferred_from_output_prefix ~kind:Intf @@ fun info -> Compile_common.interface ~hook_parse_tree:(Compiler_hooks.execute Compiler_hooks.Parse_tree_intf) @@ -116,6 +116,7 @@ let implementation_aux unix ~(flambda2 : flambda2) ~start_from Direct_to_cmm (flambda2 ~keep_symbol_tables) in with_info ~source_file ~output_prefix ~dump_ext:"cmx" ~compilation_unit + ~kind:Impl @@ fun info -> if !Flambda_backend_flags.internal_assembler then Emitaux.binary_backend_available := true; diff --git a/parsing/unit_info.ml b/parsing/unit_info.ml index a35251b0966..fcbdcbcd1a0 100644 --- a/parsing/unit_info.ml +++ b/parsing/unit_info.ml @@ -13,6 +13,7 @@ (* *) (**************************************************************************) +type intf_or_impl = Intf | Impl type modname = string type filename = string type file_prefix = string @@ -21,10 +22,12 @@ type t = { source_file: filename; prefix: file_prefix; modname: modname; + kind: intf_or_impl; } let source_file (x: t) = x.source_file let modname (x: t) = x.modname +let kind (x: t) = x.kind let prefix (x: t) = x.prefix let basename_chop_extensions basename = @@ -65,9 +68,9 @@ let check_unit_name file = Location.prerr_warning (Location.in_file (source_file file)) (Warnings.Bad_module_name (modname file)) -let make ?(check_modname=true) ~source_file prefix = +let make ?(check_modname=true) ~source_file kind prefix = let modname = modname_from_source prefix in - let p = { modname; prefix; source_file } in + let p = { modname; prefix; source_file; kind } in if check_modname then check_unit_name p; p diff --git a/parsing/unit_info.mli b/parsing/unit_info.mli index 5f25e5f819d..e873ad4e583 100644 --- a/parsing/unit_info.mli +++ b/parsing/unit_info.mli @@ -23,6 +23,7 @@ (* CR mshinwell: Consider changing [modname] to be [Compilation_unit.t] *) +type intf_or_impl = Intf | Impl type modname = string type filename = string type file_prefix = string @@ -69,19 +70,24 @@ val prefix: t -> file_prefix or compilation artifact.*) val modname: t -> modname +(** [kind u] is the kind (interface or implementation) of the unit. *) +val kind: t -> intf_or_impl + (** [check_unit_name u] prints a warning if the derived module name [modname u] should not be used as a module name as specified by {!is_unit_name}[ ~strict:true]. *) val check_unit_name : t -> unit -(** [make ~check ~source_file prefix] associates both the +(** [make ~check ~source_file kind prefix] associates both the [source_file] and the module name {!modname_from_source}[ target_prefix] to the prefix filesystem path [prefix]. If [check_modname=true], this function emits a warning if the derived module name is not valid according to {!check_unit_name}. *) -val make: ?check_modname:bool -> source_file:filename -> file_prefix -> t +val make: + ?check_modname:bool -> source_file:filename -> + intf_or_impl -> file_prefix -> t (** {1:artifact_function Build artifacts }*) module Artifact: sig From 4c0decb9628fab0e9d3450ba6975e037d6d2a71a Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Thu, 24 Apr 2025 14:54:08 +0100 Subject: [PATCH 2/3] Use `Compilation_unit.t` in place of `modname` in `Unit_info` This requires knowing the pack prefix wherever a `Unit_info.t` is created, but generally we're creating a `Compilation_unit.t` and a `Unit_info.t` at the same time so the caller already knows the pack prefix. --- asmcomp/asmpackager.ml | 27 ++++++++++----------------- bytecomp/bytepackager.ml | 26 +++++++++----------------- driver/compile_common.ml | 14 ++++++++------ ocamldoc/odoc_analyse.ml | 27 +++++++++++++-------------- parsing/unit_info.ml | 31 ++++++++++++++++++++++--------- parsing/unit_info.mli | 21 +++++++++++++++------ typing/typemod.ml | 28 ++++++++++++++++------------ utils/compilation_unit.ml | 17 ++++++++++------- utils/compilation_unit.mli | 8 +++++--- 9 files changed, 108 insertions(+), 91 deletions(-) diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index cb10767b23a..7e72a8c75cb 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -41,8 +41,9 @@ type pack_member = pm_kind: pack_member_kind } let read_member_info pack_path file = ( - let unit_info = Unit_info.Artifact.from_filename file in - let name = Unit_info.Artifact.modname unit_info |> CU.Name.of_string in + let for_pack_prefix = CU.to_prefix pack_path in + let unit_info = Unit_info.Artifact.from_filename ~for_pack_prefix file in + let name = Unit_info.Artifact.modname unit_info |> CU.name in let kind = if Unit_info.is_cmi unit_info then PM_intf @@ -91,7 +92,8 @@ type flambda2 = let make_package_object unix ~ppf_dump members target coercion ~(flambda2 : flambda2) = let pack_name = - Printf.sprintf "pack(%s)" (Unit_info.Artifact.modname target) in + Printf.sprintf "pack(%s)" + (Unit_info.Artifact.modname target |> CU.name_as_string) in Profile.record_call pack_name (fun () -> let objtemp = if !Clflags.keep_asm_file @@ -113,9 +115,7 @@ let make_package_object unix ~ppf_dump members target coercion | PM_intf -> None | PM_impl _ -> Some(CU.create_child (CU.get_current_exn ()) m.pm_name)) members in - let for_pack_prefix = CU.Prefix.from_clflags () in - let modname = CU.Name.of_string (Unit_info.Artifact.modname target) in - let compilation_unit = CU.create for_pack_prefix modname in + let compilation_unit = Unit_info.Artifact.modname target in let prefixname = Filename.remove_extension objtemp in let required_globals = Compilation_unit.Set.empty in let transl_style : Translmod.compilation_unit_style = @@ -229,11 +229,7 @@ let build_package_cmx members cmxfile ~main_module_block_size = let package_object_files unix ~ppf_dump files target targetcmx coercion ~flambda2 = - let pack_path = - let for_pack_prefix = CU.Prefix.from_clflags () in - let name = Unit_info.Artifact.modname target |> CU.Name.of_string in - CU.create for_pack_prefix name - in + let pack_path = Unit_info.Artifact.modname target in let members = map_left_right (read_member_info pack_path) files in check_units members; let main_module_block_size = @@ -250,17 +246,14 @@ let package_files unix ~ppf_dump initial_env files targetcmx ~flambda2 = try Load_path.find f with Not_found -> raise(Error(File_not_found f))) files in - let cmx = Unit_info.Artifact.from_filename targetcmx in + let for_pack_prefix = CU.Prefix.from_clflags () in + let cmx = Unit_info.Artifact.from_filename ~for_pack_prefix targetcmx in let cmi = Unit_info.companion_cmi cmx in let obj = Unit_info.companion_obj cmx in (* Set the name of the current "input" *) Location.input_name := targetcmx; (* Set the name of the current compunit *) - let comp_unit = - let for_pack_prefix = CU.Prefix.from_clflags () in - CU.create for_pack_prefix - (CU.Name.of_string (Unit_info.Artifact.modname cmi)) - in + let comp_unit = Unit_info.Artifact.modname cmx in Compilenv.reset comp_unit; Misc.try_finally (fun () -> let coercion = diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index 398242755ac..9b46299abc5 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -103,11 +103,10 @@ type pack_member = pm_kind: pack_member_kind } let read_member_info ~packed_compilation_unit file = - let member_artifact = Unit_info.Artifact.from_filename file in - let member_name = - Unit_info.Artifact.modname member_artifact |> CU.Name.of_string - in - let packed_name = CU.create_child packed_compilation_unit member_name in + let for_pack_prefix = CU.to_prefix packed_compilation_unit in + let member_artifact = Unit_info.Artifact.from_filename ~for_pack_prefix file in + let packed_name = Unit_info.Artifact.modname member_artifact in + let member_name = CU.name packed_name in let kind = (* PR#7479: make sure it is either a .cmi or a .cmo *) if Unit_info.is_cmi member_artifact then @@ -241,13 +240,8 @@ let build_global_target ~ppf_dump oc ~packed_compilation_unit state members let package_object_files ~ppf_dump files target coercion = let targetfile = Unit_info.Artifact.filename target in - let packed_compilation_unit_name = - CU.Name.of_string (Unit_info.Artifact.modname target) - in - let packed_compilation_unit = - let prefix = CU.Prefix.from_clflags () in - CU.create prefix packed_compilation_unit_name - in + let packed_compilation_unit = Unit_info.Artifact.modname target in + let packed_compilation_unit_name = CU.name packed_compilation_unit in let members = map_left_right (read_member_info ~packed_compilation_unit) files in @@ -350,11 +344,9 @@ let package_files ~ppf_dump initial_env files targetfile = try Load_path.find f with Not_found -> raise(Error(File_not_found f))) files in - let target = Unit_info.Artifact.from_filename targetfile in - let comp_unit = - CU.create (CU.Prefix.from_clflags ()) - (Unit_info.Artifact.modname target |> CU.Name.of_string) - in + let for_pack_prefix = CU.Prefix.from_clflags () in + let target = Unit_info.Artifact.from_filename ~for_pack_prefix targetfile in + let comp_unit = Unit_info.Artifact.modname target in CU.set_current (Some comp_unit); Misc.try_finally (fun () -> let coercion = diff --git a/driver/compile_common.ml b/driver/compile_common.ml index ad035780b12..d88d9c08400 100644 --- a/driver/compile_common.ml +++ b/driver/compile_common.ml @@ -15,6 +15,8 @@ open Misc +(* CR lmaurer: No longer need both [target] and [module_name] here (true in lots + of places) *) type info = { target: Unit_info.t; module_name : Compilation_unit.t; @@ -32,16 +34,16 @@ let with_info ~native ~tool_name ~source_file ~output_prefix ~compilation_unit ~kind ~dump_ext k = Compmisc.init_path (); Compmisc.init_parameters (); - let target = Unit_info.make ~source_file kind output_prefix in - let compilation_unit = + let target = match compilation_unit with - | Exactly compilation_unit -> compilation_unit + | Exactly compilation_unit -> + Unit_info.make_with_known_compilation_unit ~source_file kind + output_prefix compilation_unit | Inferred_from_output_prefix -> - let module_name = Unit_info.modname target in let for_pack_prefix = Compilation_unit.Prefix.from_clflags () in - Compilation_unit.create for_pack_prefix - (module_name |> Compilation_unit.Name.of_string) + Unit_info.make ~source_file ~for_pack_prefix kind output_prefix in + let compilation_unit = Unit_info.modname target in Compilation_unit.set_current (Some compilation_unit); Env.set_unit_name (Some compilation_unit); let env = Compmisc.initial_env() in diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index f79d78ddffc..096efc3414f 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -70,17 +70,20 @@ let no_docstring f x = Lexer.handle_docstrings := true; result -let unit_from_source source_file = - Unit_info.make ~check_modname:false ~source_file - (Filename.remove_extension source_file) +let unit_from_source source_file source_kind = + let for_pack_prefix = + (* CR-someday lmaurer: Definitely not right to assume that everything is in the same + pack and that pack is specified on the command line *) + Compilation_unit.Prefix.from_clflags () + in + Unit_info.make ~check_modname:false ~source_file source_kind + (Filename.remove_extension source_file) + ~for_pack_prefix let process_implementation_file sourcefile = init_path (); - let source = unit_from_source sourcefile in - let compilation_unit = - Compilation_unit.create (Compilation_unit.Prefix.from_clflags ()) - (Unit_info.modname source |> Compilation_unit.Name.of_string) - in + let source = unit_from_source sourcefile Unit_info.Impl in + let compilation_unit = Unit_info.modname source in Env.set_unit_name (Some compilation_unit); let inputfile = preprocess sourcefile in let env = initial_env () in @@ -113,12 +116,8 @@ let process_implementation_file sourcefile = no error occurred, else None and an error message is printed.*) let process_interface_file sourcefile = init_path (); - let unit = unit_from_source sourcefile in - let modulename = Unit_info.modname unit in - let compilation_unit = - Compilation_unit.create (Compilation_unit.Prefix.from_clflags ()) - (modulename |> Compilation_unit.Name.of_string) - in + let unit = unit_from_source sourcefile Unit_info.Intf in + let compilation_unit = Unit_info.modname unit in Env.set_unit_name (Some compilation_unit); let inputfile = preprocess sourcefile in let ast = diff --git a/parsing/unit_info.ml b/parsing/unit_info.ml index fcbdcbcd1a0..97cc406371c 100644 --- a/parsing/unit_info.ml +++ b/parsing/unit_info.ml @@ -21,7 +21,7 @@ type file_prefix = string type t = { source_file: filename; prefix: file_prefix; - modname: modname; + modname: Compilation_unit.t; kind: intf_or_impl; } @@ -48,6 +48,12 @@ let normalize = Misc.normalized_unit_filename let modname_from_source source_file = source_file |> Filename.basename |> basename_chop_extensions |> modulize +let compilation_unit_from_source ~for_pack_prefix source_file = + let modname = + modname_from_source source_file |> Compilation_unit.Name.of_string + in + Compilation_unit.create for_pack_prefix modname + let start_char = function | 'A' .. 'Z' -> true | _ -> false @@ -64,30 +70,37 @@ let is_unit_name name = && String.for_all is_identchar_latin1 name let check_unit_name file = - if not (is_unit_name (modname file)) then + let name = modname file |> Compilation_unit.name_as_string in + if not (is_unit_name name) then Location.prerr_warning (Location.in_file (source_file file)) - (Warnings.Bad_module_name (modname file)) + (Warnings.Bad_module_name name) -let make ?(check_modname=true) ~source_file kind prefix = - let modname = modname_from_source prefix in +let make ?(check_modname=true) ~source_file ~for_pack_prefix kind prefix = + let modname = compilation_unit_from_source ~for_pack_prefix prefix in let p = { modname; prefix; source_file; kind } in if check_modname then check_unit_name p; p +(* CR lmaurer: This is something of a wart: some refactoring of `Compile_common` + could probably eliminate the need for it *) +let make_with_known_compilation_unit ~source_file kind prefix modname = + { modname; prefix; source_file; kind } + module Artifact = struct type t = { source_file: filename option; filename: filename; - modname: modname; + modname: Compilation_unit.t; } let source_file x = x.source_file let filename x = x.filename let modname x = x.modname let prefix x = Filename.remove_extension (filename x) - let from_filename filename = - let modname = modname_from_source filename in + let from_filename ~for_pack_prefix filename = + let modname = compilation_unit_from_source ~for_pack_prefix filename in + { modname; filename; source_file = None } end @@ -128,6 +141,6 @@ let mli_from_source u = let is_cmi f = Filename.check_suffix (Artifact.filename f) ".cmi" let find_normalized_cmi f = - let filename = modname f ^ ".cmi" in + let filename = (modname f |> Compilation_unit.name_as_string) ^ ".cmi" in let filename = Load_path.find_normalized filename in { Artifact.filename; modname = modname f; source_file = Some f.source_file } diff --git a/parsing/unit_info.mli b/parsing/unit_info.mli index e873ad4e583..70b82e7b03a 100644 --- a/parsing/unit_info.mli +++ b/parsing/unit_info.mli @@ -21,13 +21,13 @@ (** {1:modname_from_strings Module name convention and computation} *) -(* CR mshinwell: Consider changing [modname] to be [Compilation_unit.t] *) - type intf_or_impl = Intf | Impl type modname = string type filename = string type file_prefix = string +(* CR lmaurer: These overlap with functionality in [Compilation_unit] **) + (** [modulize s] capitalizes the first letter of [s]. *) val modulize: string -> modname @@ -68,7 +68,7 @@ val prefix: t -> file_prefix (** [modname u] or [artifact_modname a] is the module name of the unit or compilation artifact.*) -val modname: t -> modname +val modname: t -> Compilation_unit.t (** [kind u] is the kind (interface or implementation) of the unit. *) val kind: t -> intf_or_impl @@ -78,7 +78,7 @@ val kind: t -> intf_or_impl by {!is_unit_name}[ ~strict:true]. *) val check_unit_name : t -> unit -(** [make ~check ~source_file kind prefix] associates both the +(** [make ~check ~source_file ~for_pack_prefix kind prefix] associates both the [source_file] and the module name {!modname_from_source}[ target_prefix] to the prefix filesystem path [prefix]. @@ -87,8 +87,17 @@ val check_unit_name : t -> unit *) val make: ?check_modname:bool -> source_file:filename -> + for_pack_prefix:Compilation_unit.Prefix.t -> intf_or_impl -> file_prefix -> t +(** [make_with_known_compilation_unit ~source_file ~for_pack_prefix kind prefix compilation_unit] + associates both the [source_file] and the module name [compilation_unit] to + the prefix filesystem path [prefix]. It is assumed that checks were + performed by [Compilation_unit]. +*) +val make_with_known_compilation_unit: + source_file:filename -> intf_or_impl -> file_prefix -> Compilation_unit.t -> t + (** {1:artifact_function Build artifacts }*) module Artifact: sig type t @@ -108,11 +117,11 @@ module Artifact: sig val filename: t -> filename (** [modname a] is the module name of the compilation artifact.*) - val modname: t -> modname + val modname: t -> Compilation_unit.t (** [from_filename filename] reconstructs the module name [modname_from_source filename] associated to the artifact [filename]. *) - val from_filename: filename -> t + val from_filename: for_pack_prefix:Compilation_unit.Prefix.t -> filename -> t end diff --git a/typing/typemod.ml b/typing/typemod.ml index 741d198ca98..e2d0ebd0faa 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -3752,7 +3752,13 @@ let check_argument_type_if_given env sourcefile actual_sig arg_module_opt = with Not_found -> raise(Error(Location.none, Env.empty, Cannot_find_argument_type arg_module)) in - let arg_cmi = Unit_info.Artifact.from_filename arg_filename in + let for_pack_prefix = + (* Packed modules can't be arguments *) + Compilation_unit.Prefix.empty + in + let arg_cmi = + Unit_info.Artifact.from_filename ~for_pack_prefix arg_filename + in let arg_sig = Env.read_signature arg_module arg_cmi in if not (Env.is_parameter_unit arg_module) then raise (Error (Location.none, env, @@ -3828,9 +3834,11 @@ let type_implementation target modulename initial_env ast = let source_intf = Unit_info.mli_from_source target in if !Clflags.cmi_file <> None || Sys.file_exists source_intf then begin + let for_pack_prefix = Compilation_unit.for_pack_prefix modulename in let compiled_intf_file = match !Clflags.cmi_file with - | Some cmi_file -> Unit_info.Artifact.from_filename cmi_file + | Some cmi_file -> + Unit_info.Artifact.from_filename ~for_pack_prefix cmi_file | None -> let cmi_file = try @@ -3839,7 +3847,7 @@ let type_implementation target modulename initial_env ast = raise(Error(Location.in_file sourcefile, Env.empty, Interface_not_compiled source_intf)) in - Unit_info.Artifact.from_filename cmi_file + Unit_info.Artifact.from_filename ~for_pack_prefix cmi_file in (* We use pre-5.2 behaviour as regards which interface-related file is reported in error messages. *) @@ -4024,16 +4032,12 @@ let package_units initial_env objfiles target_cmi modulename = let units = List.map (fun f -> - let pref = chop_extensions f in - let basename = - pref - |> Filename.basename - |> String.capitalize_ascii + let for_pack_prefix = Compilation_unit.to_prefix modulename in + let artifact = Unit_info.Artifact.from_filename ~for_pack_prefix f in + let modname = Unit_info.Artifact.modname artifact in + let global_name = + Compilation_unit.to_global_name_without_prefix modname in - let unit = Compilation_unit.Name.of_string basename in - let global_name = Global_module.Name.create_no_args basename in - let modname = Compilation_unit.create_child modulename unit in - let artifact = Unit_info.Artifact.from_filename f in let sg = Env.read_signature global_name (Unit_info.companion_cmi artifact) in diff --git a/utils/compilation_unit.ml b/utils/compilation_unit.ml index a172da7ab71..c4a5d29f417 100644 --- a/utils/compilation_unit.ml +++ b/utils/compilation_unit.ml @@ -23,7 +23,7 @@ module String = Misc.Stdlib.String type error = | Invalid_character of char * string | Bad_compilation_unit_name of string - | Child_of_instance of { child_name : string } + | Child_of_instance of { parent_name : string } | Packed_instance of { name : string } | Already_an_instance of { name : string } @@ -416,15 +416,18 @@ include T0 let create prefix name = create_full prefix name [] -let create_child parent name_ = +let to_prefix parent = + (* CR lmaurer: This is an obvious (and alarmingly longstanding) bug. Should be + checking the instance arguments, not the prefix. The result is that packed + packs are (I presume) currently broken. *) if not (Prefix.is_empty (for_pack_prefix parent)) then (* CR-someday lmaurer: Same as for [create_full] *) - raise (Error (Child_of_instance { child_name = name_ |> Name.to_string })); - let prefix = - (for_pack_prefix parent |> Prefix.to_list) @ [name parent] |> Prefix.of_list - in - create prefix name_ + raise + (Error (Child_of_instance { parent_name = name parent |> Name.to_string })); + (for_pack_prefix parent |> Prefix.to_list) @ [name parent] |> Prefix.of_list + +let create_child parent name_ = create (to_prefix parent) name_ let of_string str = let for_pack_prefix, name = diff --git a/utils/compilation_unit.mli b/utils/compilation_unit.mli index 5e42151075a..eb5da78ce36 100644 --- a/utils/compilation_unit.mli +++ b/utils/compilation_unit.mli @@ -100,8 +100,10 @@ val print_debug : Format.formatter -> t -> unit mangled in any way). *) val create : Prefix.t -> Name.t -> t -(** Create a compilation unit contained by another. Effectively uses the - parent compilation unit as the prefix. *) +(** Convert a compilation unit to a prefix. Used to form a child of a pack. *) +val to_prefix : t -> Prefix.t + +(** Combines [create] and [to_prefix]. *) val create_child : t -> Name.t -> t type argument = @@ -290,7 +292,7 @@ val split_instance_exn : t -> t * argument list type error = private | Invalid_character of char * string | Bad_compilation_unit_name of string - | Child_of_instance of { child_name : string } + | Child_of_instance of { parent_name : string } | Packed_instance of { name : string } | Already_an_instance of { name : string } From 62b9784b951ba299623823be7831995504231129 Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Thu, 24 Apr 2025 14:58:48 +0100 Subject: [PATCH 3/3] Keep the current unit as a `Unit_info.t`, not a `Compilation_unit.t` This makes downstream and upstream much better aligned, since upstream uses `Unit_info.t` in this way. (Some of the changes here are just copied from upstream, in fact.) There's a bit of awkwardness in that we often need to use dummy unit info because (unlike upstream) our typechecker can't run without a current `Compilation_unit.t` set. --- asmcomp/asmlink.ml | 10 ++++++-- asmcomp/asmpackager.ml | 5 +++- bytecomp/bytepackager.ml | 7 +++++- driver/compile_common.ml | 3 +-- driver/optcompile.ml | 6 ++--- .../testsuite/tools/codegen_main.ml | 3 ++- middle_end/compilenv.ml | 5 ++-- middle_end/compilenv.mli | 2 +- middle_end/flambda2/cmx/flambda_cmx.ml | 10 +++++--- middle_end/flambda2/cmx/flambda_cmx_format.ml | 5 +++- middle_end/flambda2/parser/parse_flambda.ml | 7 +++--- .../tests/api_tests/extension_meet.ml | 3 ++- middle_end/flambda2/tests/meet_test.ml | 3 ++- middle_end/flambda2/tests/tools/flexpect.ml | 3 ++- middle_end/flambda2/tests/tools/roundtrip.ml | 3 ++- ocamldoc/odoc_analyse.ml | 6 ++--- otherlibs/dynlink/dune | 4 ++-- parsing/unit_info.ml | 10 ++++++++ parsing/unit_info.mli | 11 +++++++++ testsuite/tools/codegen_main.ml | 3 ++- tools/generate_cached_generic_functions.ml | 8 +++++-- toplevel/native/opttoploop.ml | 5 +++- typing/datarepr.mli | 4 ++-- typing/env.ml | 24 +++++++++++++------ typing/env.mli | 4 ++-- typing/shape.ml | 2 +- typing/shape.mli | 2 +- utils/compilation_unit.ml | 17 +++++++------ utils/compilation_unit.mli | 6 +++-- 29 files changed, 126 insertions(+), 55 deletions(-) diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index 96bcd8c4444..85d417c3aca 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -364,7 +364,10 @@ let make_startup_file unix ~ppf_dump ~sourcefile_for_dwarf genfns units cached_g let startup_comp_unit = CU.create CU.Prefix.empty (CU.Name.of_string "_startup") in - Compilenv.reset startup_comp_unit; + let startup_unit_info = + Unit_info.make_dummy ~input_name:"caml_startup" startup_comp_unit + in + Compilenv.reset startup_unit_info; Emitaux.Dwarf_helpers.init ~disable_dwarf:(not !Dwarf_flags.dwarf_for_startup_file) ~sourcefile:sourcefile_for_dwarf; Emit.begin_assembly unix; @@ -421,7 +424,10 @@ let make_shared_startup_file unix ~ppf_dump ~sourcefile_for_dwarf genfns units = let shared_startup_comp_unit = CU.create CU.Prefix.empty (CU.Name.of_string "_shared_startup") in - Compilenv.reset shared_startup_comp_unit; + let shared_startup_unit_info = + Unit_info.make_dummy ~input_name:"caml_startup" shared_startup_comp_unit + in + Compilenv.reset shared_startup_unit_info; Emitaux.Dwarf_helpers.init ~disable_dwarf:(not !Dwarf_flags.dwarf_for_startup_file) ~sourcefile:sourcefile_for_dwarf; Emit.begin_assembly unix; diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index 7e72a8c75cb..64d7a3137fd 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -253,8 +253,11 @@ let package_files unix ~ppf_dump initial_env files targetcmx ~flambda2 = (* Set the name of the current "input" *) Location.input_name := targetcmx; (* Set the name of the current compunit *) + let unit_info = + Unit_info.of_artifact Impl cmx ~dummy_source_file:targetcmx + in let comp_unit = Unit_info.Artifact.modname cmx in - Compilenv.reset comp_unit; + Compilenv.reset unit_info; Misc.try_finally (fun () -> let coercion = Typemod.package_units initial_env files cmi comp_unit in diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index 9b46299abc5..b7470cad1f6 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -347,7 +347,12 @@ let package_files ~ppf_dump initial_env files targetfile = let for_pack_prefix = CU.Prefix.from_clflags () in let target = Unit_info.Artifact.from_filename ~for_pack_prefix targetfile in let comp_unit = Unit_info.Artifact.modname target in - CU.set_current (Some comp_unit); + let unit_info = + (* Do what [asmpackager] does and use the target .cmx as a dummy source + file *) + Unit_info.of_artifact Impl target ~dummy_source_file:targetfile + in + Env.set_unit_name (Some unit_info); Misc.try_finally (fun () -> let coercion = Typemod.package_units initial_env files (Unit_info.companion_cmi target) diff --git a/driver/compile_common.ml b/driver/compile_common.ml index d88d9c08400..145686d5be5 100644 --- a/driver/compile_common.ml +++ b/driver/compile_common.ml @@ -44,8 +44,7 @@ let with_info ~native ~tool_name ~source_file ~output_prefix Unit_info.make ~source_file ~for_pack_prefix kind output_prefix in let compilation_unit = Unit_info.modname target in - Compilation_unit.set_current (Some compilation_unit); - Env.set_unit_name (Some compilation_unit); + Env.set_unit_name (Some target); let env = Compmisc.initial_env() in let dump_file = String.concat "." [output_prefix; dump_ext] in Compmisc.with_ppf_dump ~file_prefix:dump_file (fun ppf_dump -> diff --git a/driver/optcompile.ml b/driver/optcompile.ml index d05e573a807..2325e3187bb 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -84,7 +84,7 @@ type flambda2 = (* Emit assembly directly from Linear IR *) let emit unix i = - Compilenv.reset i.module_name; + Compilenv.reset i.target; Asmgen.compile_implementation_linear unix (Unit_info.prefix i.target) ~progname:(Unit_info.source_file i.target) @@ -124,7 +124,7 @@ let implementation_aux unix ~(flambda2 : flambda2) ~start_from | Parsing -> let backend info ({ structure; coercion; argument_interface; _ } : Typedtree.implementation) = - Compilenv.reset info.module_name; + Compilenv.reset info.target; let argument_coercion = match argument_interface with | Some { ai_coercion_from_primary; ai_signature = _ } -> @@ -149,7 +149,7 @@ let implementation_aux unix ~(flambda2 : flambda2) ~start_from info ~backend | Emit -> emit unix info ~ppf_dump:info.ppf_dump | Instantiation { runtime_args; main_module_block_size; arg_descr } -> - Compilenv.reset info.module_name; + Compilenv.reset info.target; begin match !Clflags.as_argument_for with | Some _ -> diff --git a/flambda-backend/testsuite/tools/codegen_main.ml b/flambda-backend/testsuite/tools/codegen_main.ml index f907c5fb4f2..ee9cebd8714 100644 --- a/flambda-backend/testsuite/tools/codegen_main.ml +++ b/flambda-backend/testsuite/tools/codegen_main.ml @@ -22,7 +22,8 @@ let compile_file filename = Emitaux.output_channel := open_out out_name end; (* otherwise, stdout *) let compilation_unit = "test" |> Compilation_unit.of_string in - Compilenv.reset compilation_unit; + let unit_info = Unit_info.make_dummy ~input_name:"test" compilation_unit in + Compilenv.reset unit_info; Emit.begin_assembly (module Unix : Compiler_owee.Unix_intf.S); let ic = open_in filename in let lb = Lexing.from_channel ic in diff --git a/middle_end/compilenv.ml b/middle_end/compilenv.ml index 6200880d2c1..e6d7e61e6a4 100644 --- a/middle_end/compilenv.ml +++ b/middle_end/compilenv.ml @@ -65,10 +65,11 @@ let current_unit = ui_external_symbols = []; } -let reset compilation_unit = +let reset unit_info = + let compilation_unit = Unit_info.modname unit_info in Infos_table.clear global_infos_table; Zero_alloc_info.reset cached_zero_alloc_info; - CU.set_current (Some compilation_unit); + Env.set_unit_name (Some unit_info); current_unit.ui_unit <- compilation_unit; current_unit.ui_defines <- [compilation_unit]; current_unit.ui_arg_descr <- None; diff --git a/middle_end/compilenv.mli b/middle_end/compilenv.mli index 975b7359c18..11c12688f6f 100644 --- a/middle_end/compilenv.mli +++ b/middle_end/compilenv.mli @@ -21,7 +21,7 @@ open Cmx_format -val reset : Compilation_unit.t -> unit +val reset : Unit_info.t -> unit (* Reset the environment and record the name of the unit being compiled (including any associated -for-pack prefix). *) diff --git a/middle_end/flambda2/cmx/flambda_cmx.ml b/middle_end/flambda2/cmx/flambda_cmx.ml index 43ec1943e59..fd5c1e74f45 100644 --- a/middle_end/flambda2/cmx/flambda_cmx.ml +++ b/middle_end/flambda2/cmx/flambda_cmx.ml @@ -82,12 +82,16 @@ let all_predefined_exception_symbols () = Predef.all_predef_exns |> List.map symbol_for_global |> Symbol.Set.of_list let predefined_exception_typing_env () = - let comp_unit = Compilation_unit.get_current () in - Compilation_unit.set_current (Some Compilation_unit.predef_exn); + let unit_info = Env.get_unit_name () in + let predef_unit_info = + Unit_info.make_dummy ~input_name:"" + Compilation_unit.predef_exn + in + Env.set_unit_name (Some predef_unit_info); let typing_env = TE.Serializable.predefined_exceptions (all_predefined_exception_symbols ()) in - Compilation_unit.set_current comp_unit; + Env.set_unit_name unit_info; typing_env let create_loader ~get_module_info = diff --git a/middle_end/flambda2/cmx/flambda_cmx_format.ml b/middle_end/flambda2/cmx/flambda_cmx_format.ml index ac28a8d62b3..cb565d6c339 100644 --- a/middle_end/flambda2/cmx/flambda_cmx_format.ml +++ b/middle_end/flambda2/cmx/flambda_cmx_format.ml @@ -213,7 +213,10 @@ let merge t1_opt t2_opt = let print0 ~sections ~print_typing_env ~print_code ~print_offsets ppf t = Format.fprintf ppf "@[Original unit:@ %a@]@;" Compilation_unit.print t.original_compilation_unit; - Compilation_unit.set_current (Some t.original_compilation_unit); + let unit_info = + Unit_info.make_dummy ~input_name:"" t.original_compilation_unit + in + Env.set_unit_name (Some unit_info); let typing_env, code = import_typing_env_and_code0 ~sections t in if print_typing_env then diff --git a/middle_end/flambda2/parser/parse_flambda.ml b/middle_end/flambda2/parser/parse_flambda.ml index 6fdd0ddbc02..a241cd1dc79 100644 --- a/middle_end/flambda2/parser/parse_flambda.ml +++ b/middle_end/flambda2/parser/parse_flambda.ml @@ -153,8 +153,9 @@ let parse filename = parse_fexpr filename |> Result.map (fun fexpr -> let comp_unit = make_compilation_unit ~extension:".fl" ~filename () in - let old_comp_unit = Compilation_unit.get_current () in - Compilation_unit.set_current (Some comp_unit); + let unit_info = Unit_info.make_dummy ~input_name:filename comp_unit in + let old_unit_info = Env.get_unit_name () in + Env.set_unit_name (Some unit_info); let flambda = Fexpr_to_flambda.conv comp_unit fexpr in - Compilation_unit.set_current old_comp_unit; + Env.set_unit_name old_unit_info; flambda) diff --git a/middle_end/flambda2/tests/api_tests/extension_meet.ml b/middle_end/flambda2/tests/api_tests/extension_meet.ml index c2d3d1b07a3..2ecc65152a1 100644 --- a/middle_end/flambda2/tests/api_tests/extension_meet.ml +++ b/middle_end/flambda2/tests/api_tests/extension_meet.ml @@ -188,5 +188,6 @@ let _ = let linkage_name = Compilation_unit.Name.of_string "camlTest" in Compilation_unit.create Compilation_unit.Prefix.empty linkage_name in - Compilation_unit.set_current (Some comp_unit); + let unit_info = Unit_info.make_dummy ~input_name:"camlTest" comp_unit in + Env.set_unit_name (Some unit_info); test_double_recursion () diff --git a/middle_end/flambda2/tests/meet_test.ml b/middle_end/flambda2/tests/meet_test.ml index b33aeb635b4..d0dfe75ef2a 100644 --- a/middle_end/flambda2/tests/meet_test.ml +++ b/middle_end/flambda2/tests/meet_test.ml @@ -424,7 +424,8 @@ let test_meet_bottom_after_alias () = let () = let comp_unit = "Meet_test" |> Compilation_unit.of_string in - Compilation_unit.set_current (Some comp_unit); + let unit_info = Unit_info.make_dummy ~input_name:"meet_test" comp_unit in + Env.set_unit_name (Some unit_info); Format.eprintf "MEET CHAINS WITH TWO VARS@\n@."; test_meet_chains_two_vars (); Format.eprintf "@.MEET CHAINS WITH THREE VARS@\n@."; diff --git a/middle_end/flambda2/tests/tools/flexpect.ml b/middle_end/flambda2/tests/tools/flexpect.ml index 63cfc7f4cbc..9053c424fd8 100644 --- a/middle_end/flambda2/tests/tools/flexpect.ml +++ b/middle_end/flambda2/tests/tools/flexpect.ml @@ -35,7 +35,8 @@ end let run_expect_test ~get_module_info ~extension ~filename ({ before; after = expected } : Fexpr.expect_test_spec) : Test_outcome.t = let comp_unit = Parse_flambda.make_compilation_unit ~extension ~filename () in - Compilation_unit.set_current (Some comp_unit); + let unit_info = Unit_info.make_dummy ~input_name:filename comp_unit in + Env.set_unit_name (Some unit_info); let before_fl = Fexpr_to_flambda.conv comp_unit before in check_invariants before_fl; let cmx_loader = Flambda_cmx.create_loader ~get_module_info in diff --git a/middle_end/flambda2/tests/tools/roundtrip.ml b/middle_end/flambda2/tests/tools/roundtrip.ml index 8774d6fa813..84c4dee6464 100644 --- a/middle_end/flambda2/tests/tools/roundtrip.ml +++ b/middle_end/flambda2/tests/tools/roundtrip.ml @@ -28,9 +28,10 @@ let () = let modname = Parse_flambda.make_compilation_unit ~filename:file ~extension:".fl" () in + let unit_info = Unit_info.make_dummy ~input_name:file modname in (* Need to get this right or the conversion will complain about binding non-local symbols *) - Compilation_unit.set_current (Some modname); + Env.set_unit_name (Some unit_info); let unit = match Parse_flambda.parse file with | Ok unit -> unit diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index 096efc3414f..5fabcc41673 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -30,7 +30,7 @@ let init_path () = Compmisc.init_path () let initial_env () = let current = match Env.get_unit_name () with - | Some cu -> cu |> Compilation_unit.full_path_as_string + | Some cu -> Unit_info.modname cu |> Compilation_unit.full_path_as_string | None -> "" in let initial = !Odoc_global.initially_opened_module in @@ -84,7 +84,7 @@ let process_implementation_file sourcefile = init_path (); let source = unit_from_source sourcefile Unit_info.Impl in let compilation_unit = Unit_info.modname source in - Env.set_unit_name (Some compilation_unit); + Env.set_unit_name (Some source); let inputfile = preprocess sourcefile in let env = initial_env () in try @@ -118,7 +118,7 @@ let process_interface_file sourcefile = init_path (); let unit = unit_from_source sourcefile Unit_info.Intf in let compilation_unit = Unit_info.modname unit in - Env.set_unit_name (Some compilation_unit); + Env.set_unit_name (Some unit); let inputfile = preprocess sourcefile in let ast = Pparse.file ~tool_name inputfile diff --git a/otherlibs/dynlink/dune b/otherlibs/dynlink/dune index eec16a3af2e..81ab15bface 100644 --- a/otherlibs/dynlink/dune +++ b/otherlibs/dynlink/dune @@ -609,9 +609,9 @@ .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Cmi_format.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Debuginfo.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Consistbl.cmo + .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Unit_info.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Shape.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Datarepr.cmo - .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Unit_info.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__CamlinternalMenhirLib.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Parser_types.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Parser.cmo @@ -705,9 +705,9 @@ .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Cmi_format.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Debuginfo.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Consistbl.cmx + .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Unit_info.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Shape.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Datarepr.cmx - .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Unit_info.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__CamlinternalMenhirLib.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Parser_types.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Parser.cmx diff --git a/parsing/unit_info.ml b/parsing/unit_info.ml index 97cc406371c..ac73012e4f3 100644 --- a/parsing/unit_info.ml +++ b/parsing/unit_info.ml @@ -86,6 +86,10 @@ let make ?(check_modname=true) ~source_file ~for_pack_prefix kind prefix = let make_with_known_compilation_unit ~source_file kind prefix modname = { modname; prefix; source_file; kind } +let make_dummy ~input_name modname = + make_with_known_compilation_unit ~source_file:input_name + Impl input_name modname + module Artifact = struct type t = { @@ -105,6 +109,12 @@ module Artifact = struct end +let of_artifact ~dummy_source_file kind (a : Artifact.t) = + let modname = Artifact.modname a in + let prefix = Artifact.prefix a in + let source_file = Option.value a.source_file ~default:dummy_source_file in + { modname; prefix; source_file; kind } + let mk_artifact ext u = { Artifact.filename = u.prefix ^ ext; diff --git a/parsing/unit_info.mli b/parsing/unit_info.mli index 70b82e7b03a..961a0c4a427 100644 --- a/parsing/unit_info.mli +++ b/parsing/unit_info.mli @@ -98,6 +98,12 @@ val make: val make_with_known_compilation_unit: source_file:filename -> intf_or_impl -> file_prefix -> Compilation_unit.t -> t +(** [make_dummy ~input_name compilation_unit] is used in places where there's no + actual source file but we do need to specify a [Compilation_unit.t]. The + [input_name] is a string like "startup", suitable as the value for + [Location.input_name] as well. *) +val make_dummy: input_name:string -> Compilation_unit.t -> t + (** {1:artifact_function Build artifacts }*) module Artifact: sig type t @@ -177,3 +183,8 @@ val is_cmi: Artifact.t -> bool name [modname u]. @raise Not_found if no such cmi exists *) val find_normalized_cmi: t -> Artifact.t + +(** [of_artifact ~dummy_source_file kind a] builds a [Unit_info.t] from a + [Unit_info.Artifact.t], using [dummy_source_file] as the filename if the + artifact doesn't have one attached. *) +val of_artifact : dummy_source_file:filename -> intf_or_impl -> Artifact.t -> t diff --git a/testsuite/tools/codegen_main.ml b/testsuite/tools/codegen_main.ml index 881875262ab..e3b074daff3 100644 --- a/testsuite/tools/codegen_main.ml +++ b/testsuite/tools/codegen_main.ml @@ -25,7 +25,8 @@ let compile_file filename = Compilation_unit.create Compilation_unit.Prefix.empty ("test" |> Compilation_unit.Name.of_string) in - Compilenv.reset compilation_unit; + let unit_info = Unit_info.make_dummy ~input_name:"test" compilation_unit in + Compilenv.reset unit_info; Clflags.cmm_invariants := true; Emit.begin_assembly(); let ic = open_in filename in diff --git a/tools/generate_cached_generic_functions.ml b/tools/generate_cached_generic_functions.ml index 41754c413e8..85c38c3efc6 100644 --- a/tools/generate_cached_generic_functions.ml +++ b/tools/generate_cached_generic_functions.ml @@ -31,9 +31,13 @@ open Config module CU = Compilation_unit let make_cached_generic_functions unix ~ppf_dump ~id genfns = - Location.input_name := Generic_fns.Partition.name id; (* set name of "current" input *) + let name = Generic_fns.Partition.name id in + Location.input_name := name; (* set name of "current" input *) let startup_comp_unit = Generic_fns.Partition.to_cu id in - Compilenv.reset startup_comp_unit; + let startup_unit_info = + Unit_info.make_dummy ~input_name:name startup_comp_unit + in + Compilenv.reset startup_unit_info; Emit.begin_assembly unix; let compile_phrase p = Asmgen.compile_phrase ~ppf_dump p in Profile.record_call "genfns" (fun () -> diff --git a/toplevel/native/opttoploop.ml b/toplevel/native/opttoploop.ml index 0316c3b85e7..9ca0cd243af 100644 --- a/toplevel/native/opttoploop.ml +++ b/toplevel/native/opttoploop.ml @@ -393,7 +393,10 @@ let execute_phrase print_outcome ppf phr = Compilation_unit.create Compilation_unit.Prefix.empty (!phrase_name |> Compilation_unit.Name.of_string) in - Compilenv.reset compilation_unit; + let unit_info = + Unit_info.make_dummy ~input_name:!phrase_name compilation_unit + in + Compilenv.reset unit_info; Typecore.reset_delayed_checks (); let (str, sg, names, _shape, newenv) = Typemod.type_toplevel_phrase oldenv oldsig sstr diff --git a/typing/datarepr.mli b/typing/datarepr.mli index 606fa6eab1b..053e2aded5b 100644 --- a/typing/datarepr.mli +++ b/typing/datarepr.mli @@ -19,7 +19,7 @@ open Types val extension_descr: - current_unit:Compilation_unit.t option -> Path.t -> extension_constructor -> + current_unit:Unit_info.t option -> Path.t -> extension_constructor -> constructor_description val labels_of_type: @@ -29,7 +29,7 @@ val unboxed_labels_of_type: Path.t -> type_declaration -> (Ident.t * unboxed_label_description) list val constructors_of_type: - current_unit:Compilation_unit.t option -> Path.t -> type_declaration -> + current_unit:Unit_info.t option -> Path.t -> type_declaration -> (Ident.t * constructor_description) list diff --git a/typing/env.ml b/typing/env.ml index 8461bfa1b30..e083177ff6f 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -1007,18 +1007,22 @@ let rec address_head = function (* The name of the compilation unit currently compiled. *) module Current_unit_name : sig - val get : unit -> Compilation_unit.t option - val set : Compilation_unit.t option -> unit + val get : unit -> Unit_info.t option + val set : Unit_info.t option -> unit val is : string -> bool val is_ident : Ident.t -> bool val is_path : Path.t -> bool end = struct + let current_unit : Unit_info.t option ref = + ref None let get () = - Compilation_unit.get_current () - let set comp_unit = - Compilation_unit.set_current comp_unit + !current_unit + let set cu = + current_unit := cu + let get_cu () = + Option.map Unit_info.modname (get ()) let get_name () = - Option.map Compilation_unit.name (get ()) + Option.map Compilation_unit.name (get_cu ()) let is name = let current_name_string = Option.map Compilation_unit.Name.to_string (get_name ()) @@ -1181,7 +1185,7 @@ let reset_declaration_caches () = () let reset_cache ~preserve_persistent_env = - Compilation_unit.set_current None; + Current_unit_name.set None; if not preserve_persistent_env then Persistent_env.clear !persistent_env; reset_declaration_caches (); @@ -4667,3 +4671,9 @@ let () = | _ -> None ) + +let () = + let get_current_compilation_unit () = + Option.map Unit_info.modname (get_unit_name ()) + in + Compilation_unit.Private.fwd_get_current := get_current_compilation_unit diff --git a/typing/env.mli b/typing/env.mli index 507ce49d348..743870a664c 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -518,8 +518,8 @@ val reset_cache: preserve_persistent_env:bool -> unit val reset_cache_toplevel: unit -> unit (* Remember the name of the current compilation unit. *) -val set_unit_name: Compilation_unit.t option -> unit -val get_unit_name: unit -> Compilation_unit.t option +val set_unit_name: Unit_info.t option -> unit +val get_unit_name: unit -> Unit_info.t option (* Read, save a signature to/from a file. *) val read_signature: diff --git a/typing/shape.ml b/typing/shape.ml index af15989695d..205599f2c82 100644 --- a/typing/shape.ml +++ b/typing/shape.ml @@ -70,7 +70,7 @@ module Uid = struct incr id; let comp_unit = match current_unit with - | Some cu -> cu |> Compilation_unit.full_path_as_string + | Some cu -> Unit_info.modname cu |> Compilation_unit.full_path_as_string | None -> "" in Item { comp_unit; id = !id } diff --git a/typing/shape.mli b/typing/shape.mli index 53f0d818d47..3a18698cb0b 100644 --- a/typing/shape.mli +++ b/typing/shape.mli @@ -64,7 +64,7 @@ module Uid : sig val reinit : unit -> unit - val mk : current_unit:Compilation_unit.t option -> t + val mk : current_unit:Unit_info.t option -> t val of_compilation_unit_id : Compilation_unit.t -> t val of_compilation_unit_name : Compilation_unit.Name.t -> t val of_predef_id : Ident.t -> t diff --git a/utils/compilation_unit.ml b/utils/compilation_unit.ml index c4a5d29f417..6fa0dbdd87c 100644 --- a/utils/compilation_unit.ml +++ b/utils/compilation_unit.ml @@ -640,17 +640,20 @@ let print_debug ppf t = "@[(@[(for_pack_prefix@ %a)@]@;@[(name@ %a)@]" Prefix.print for_pack_prefix Name.print name -let current = ref None +let fwd_get_current : (unit -> t option) ref = ref (fun () -> assert false) -let set_current t_opt = current := t_opt +let get_current () = !fwd_get_current () -let get_current () = !current - -let get_current_or_dummy () = Option.value !current ~default:dummy +let get_current_or_dummy () = Option.value (get_current ()) ~default:dummy let get_current_exn () = - match !current with + match get_current () with | 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 get_current () with None -> false | Some t' -> equal t t' + +module Private = struct + let fwd_get_current = fwd_get_current +end diff --git a/utils/compilation_unit.mli b/utils/compilation_unit.mli index eb5da78ce36..d993f2534a2 100644 --- a/utils/compilation_unit.mli +++ b/utils/compilation_unit.mli @@ -299,8 +299,6 @@ type error = private (** The exception raised by conversion functions in this module. *) exception Error of error -val set_current : t option -> unit - val get_current : unit -> t option val get_current_or_dummy : unit -> t @@ -308,3 +306,7 @@ val get_current_or_dummy : unit -> t val get_current_exn : unit -> t val is_current : t -> bool + +module Private : sig + val fwd_get_current : (unit -> t option) ref +end