From 3cd36f0058250d2e10abfed5b5faf24f50d262d1 Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Tue, 18 Oct 2022 09:14:07 +0100 Subject: [PATCH] flambda-backend: Have Lambda `Pgetglobal` and `Psetglobal` take `Compilation_unit.t` (#896) * Have Lambda `Pgetglobal` and `Psetglobal` take `Compilation_unit.t` Also introduces the `Pgetpredef` primitive to cover the case where the original `Pgetglobal` took a predefined `Ident.t`. This is the first step toward having `Compilation_unit.t` take the place of known-global `Ident.t`s. There have been about as few API changes as I can get away with, which in many places means converting between `Ident.t` and `Compilation_unit.t`, which we very much want to get away from in the long term, since an `Ident.t` is ambiguous as to whether it has its proper prefix (usually not, but occasionally so!). Co-authored-by: Mark Shinwell --- bytecomp/bytegen.ml | 10 +++-- lambda/lambda.ml | 19 ++++++--- lambda/lambda.mli | 5 ++- lambda/printlambda.ml | 6 ++- lambda/translmod.ml | 51 ++++++++++++++++++------ lambda/translobj.mli | 2 +- lambda/translprim.ml | 2 +- middle_end/closure/closure.ml | 10 ++++- middle_end/convert_primitives.ml | 1 + middle_end/flambda/closure_conversion.ml | 17 +++++--- middle_end/internal_variable_names.ml | 4 ++ otherlibs/dynlink/dune | 20 ++++++---- toplevel/opttoploop.ml | 7 +++- utils/compilation_unit.ml | 5 +++ utils/compilation_unit.mli | 13 ++++++ 15 files changed, 128 insertions(+), 44 deletions(-) diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 740f287e23d..44fc3574c66 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -112,7 +112,8 @@ let preserve_tailcall_for_prim = function Pidentity | Popaque | Pdirapply _ | Prevapply _ | Psequor | Psequand | Pobj_magic -> true - | Pbytes_to_string | Pbytes_of_string | Pignore | Pgetglobal _ | Psetglobal _ + | Pbytes_to_string | Pbytes_of_string | Pignore + | Pgetglobal _ | Psetglobal _ | Pgetpredef _ | Pmakeblock _ | Pmakefloatblock _ | Pfield _ | Pfield_computed _ | Psetfield _ | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Pduprecord _ @@ -390,8 +391,11 @@ let comp_bint_primitive bi suff args = let comp_primitive p args = match p with - Pgetglobal id -> Kgetglobal id - | Psetglobal id -> Ksetglobal id + Pgetglobal cu -> + Kgetglobal (cu |> Compilation_unit.to_global_ident_for_legacy_code) + | Psetglobal cu -> + Ksetglobal (cu |> Compilation_unit.to_global_ident_for_legacy_code) + | Pgetpredef id -> Kgetglobal id | Pintcomp cmp -> Kintcomp cmp | Pcompare_ints -> Kccall("caml_int_compare", 2) | Pcompare_floats -> Kccall("caml_float_compare", 2) diff --git a/lambda/lambda.ml b/lambda/lambda.ml index 9627c24dd52..1ff4a176f54 100644 --- a/lambda/lambda.ml +++ b/lambda/lambda.ml @@ -110,8 +110,9 @@ type primitive = | Prevapply of region_close | Pdirapply of region_close (* Globals *) - | Pgetglobal of Ident.t - | Psetglobal of Ident.t + | Pgetglobal of Compilation_unit.t + | Psetglobal of Compilation_unit.t + | Pgetpredef of Ident.t (* Operations on heap blocks *) | Pmakeblock of int * mutable_flag * block_shape * alloc_mode | Pmakefloatblock of mutable_flag * alloc_mode @@ -836,8 +837,16 @@ let rec patch_guarded patch = function let rec transl_address loc = function | Env.Aident id -> - if Ident.is_global_or_predef id - then Lprim(Pgetglobal id, [], loc) + if Ident.is_predef id + then Lprim (Pgetpredef id, [], loc) + else if Ident.is_global id + then + (* Prefixes are currently always empty *) + let cu = + Compilation_unit.create Compilation_unit.Prefix.empty + (Ident.name id |> Compilation_unit.Name.of_string) + in + Lprim(Pgetglobal cu, [], loc) else Lvar id | Env.Adot(addr, pos) -> Lprim(Pfield (pos, Reads_agree), [transl_address loc addr], loc) @@ -1191,7 +1200,7 @@ let mod_setfield pos = let primitive_may_allocate : primitive -> alloc_mode option = function | Pidentity | Pbytes_to_string | Pbytes_of_string | Pignore -> None | Prevapply _ | Pdirapply _ -> Some alloc_local - | Pgetglobal _ | Psetglobal _ -> None + | Pgetglobal _ | Psetglobal _ | Pgetpredef _ -> None | Pmakeblock (_, _, _, m) -> Some m | Pmakefloatblock (_, m) -> Some m | Pfield _ | Pfield_computed _ | Psetfield _ | Psetfield_computed _ -> None diff --git a/lambda/lambda.mli b/lambda/lambda.mli index 179684cc690..5d79f2bc772 100644 --- a/lambda/lambda.mli +++ b/lambda/lambda.mli @@ -77,8 +77,9 @@ type primitive = | Prevapply of region_close | Pdirapply of region_close (* Globals *) - | Pgetglobal of Ident.t - | Psetglobal of Ident.t + | Pgetglobal of Compilation_unit.t + | Psetglobal of Compilation_unit.t + | Pgetpredef of Ident.t (* Operations on heap blocks *) | Pmakeblock of int * mutable_flag * block_shape * alloc_mode | Pmakefloatblock of mutable_flag * alloc_mode diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml index 6b796a580d4..574c5945728 100644 --- a/lambda/printlambda.ml +++ b/lambda/printlambda.ml @@ -220,8 +220,9 @@ let primitive ppf = function | Pignore -> fprintf ppf "ignore" | Prevapply _ -> fprintf ppf "revapply" | Pdirapply _ -> fprintf ppf "dirapply" - | Pgetglobal id -> fprintf ppf "global %a" Ident.print id - | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id + | Pgetglobal cu -> fprintf ppf "global %a!" Compilation_unit.print cu + | Psetglobal cu -> fprintf ppf "setglobal %a!" Compilation_unit.print cu + | Pgetpredef id -> fprintf ppf "getpredef %a!" Ident.print id | Pmakeblock(tag, Immutable, shape, mode) -> fprintf ppf "make%sblock %i%a" (alloc_mode mode) tag block_shape shape @@ -451,6 +452,7 @@ let name_of_primitive = function | Pdirapply _ -> "Pdirapply" | Pgetglobal _ -> "Pgetglobal" | Psetglobal _ -> "Psetglobal" + | Pgetpredef _ -> "Pgetpredef" | Pmakeblock _ -> "Pmakeblock" | Pmakefloatblock _ -> "Pmakefloatblock" | Pfield _ -> "Pfield" diff --git a/lambda/translmod.ml b/lambda/translmod.ml index 436657bcf81..44c799fe296 100644 --- a/lambda/translmod.ml +++ b/lambda/translmod.ml @@ -47,6 +47,18 @@ let cons_opt x_opt xs = | None -> xs | Some x -> x :: xs +(* Hacky shims. Note that we only ever create compilation units with + empty prefixes, so these are indeed safe. *) +let compilation_unit_of_modname modname = + Compilation_unit.create Compilation_unit.Prefix.empty + (modname |> Compilation_unit.Name.of_string) +let compilation_unit_of_ident ident = + Ident.name ident |> compilation_unit_of_modname +let ident_of_compilation_unit compilation_unit = + assert (Compilation_unit.Prefix.is_empty + (Compilation_unit.for_pack_prefix compilation_unit)); + compilation_unit |> Compilation_unit.to_global_ident_for_legacy_code + (* Keep track of the root path (from the root of the namespace to the currently compiled module expression). Useful for naming extensions. *) @@ -869,7 +881,9 @@ let scan_used_globals lam = let rec scan lam = Lambda.iter_head_constructor scan lam; match lam with - Lprim ((Pgetglobal id | Psetglobal id), _, _) -> + Lprim ((Pgetglobal cu | Psetglobal cu), _, _) -> + globals := Ident.Set.add (cu |> ident_of_compilation_unit) !globals + | Lprim (Pgetpredef id, _, _) -> globals := Ident.Set.add id !globals | _ -> () in @@ -921,8 +935,11 @@ let transl_implementation module_name (str, cc) = let implementation = transl_implementation_flambda module_name (str, cc) in + let compilation_unit = + implementation.module_ident |> compilation_unit_of_ident + in let code = - Lprim (Psetglobal implementation.module_ident, [implementation.code], + Lprim (Psetglobal compilation_unit, [implementation.code], Loc_unknown) in { implementation with code } @@ -1069,7 +1086,8 @@ let transl_store_subst = ref Ident.Map.empty let nat_toplevel_name id = try match Ident.Map.find id !transl_store_subst with | Lprim(Pfield (pos, _), - [Lprim(Pgetglobal glob, [], _)], _) -> (glob,pos) + [Lprim(Pgetglobal glob, [], _)], _) -> + ((glob |> ident_of_compilation_unit),pos) | _ -> raise Not_found with Not_found -> fatal_error("Translmod.nat_toplevel_name: " ^ Ident.unique_name id) @@ -1446,7 +1464,9 @@ let transl_store_structure ~scopes glob map prims aliases str = in let aliases = make_sequence store_alias aliases in List.fold_right store_primitive prims - (transl_store ~scopes (global_path glob) !transl_store_subst aliases str) + (transl_store ~scopes + (global_path (glob |> ident_of_compilation_unit)) + !transl_store_subst aliases str) (* Transform a coercion and the list of value identifiers defined by a toplevel structure into a table [id -> (pos, coercion)], @@ -1504,6 +1524,7 @@ let transl_store_gen ~scopes module_name ({ str_items = str }, restr) topl = Translcore.clear_probe_handlers (); Translprim.clear_used_primitives (); let module_id = Ident.create_persistent module_name in + let compilation_unit = module_id |> compilation_unit_of_ident in let (map, prims, aliases, size) = build_ident_map restr (defined_idents str) (more_idents str) in let f str = @@ -1513,11 +1534,12 @@ let transl_store_gen ~scopes module_name ({ str_items = str }, restr) topl = assert (size = 0); Lambda.subst (fun _ _ env -> env) !transl_store_subst (transl_exp ~scopes expr) - | str -> transl_store_structure ~scopes module_id map prims aliases str + | str -> + transl_store_structure ~scopes compilation_unit map prims aliases str in Translcore.declare_probe_handlers expr in - transl_store_label_init module_id size f str + transl_store_label_init compilation_unit size f str (*size, transl_label_init (transl_store_structure module_id map prims str)*) let transl_store_phrases module_name str = @@ -1543,7 +1565,7 @@ let transl_store_implementation module_name (str, restr) = (* Compile a toplevel phrase *) -let toploop_ident = Ident.create_persistent "Toploop" +let toploop_unit = Compilation_unit.of_string "Toploop" let toploop_getvalue_pos = 0 (* position of getvalue in module Toploop *) let toploop_setvalue_pos = 1 (* position of setvalue in module Toploop *) @@ -1561,7 +1583,7 @@ let toploop_getvalue id = Lapply{ ap_loc=Loc_unknown; ap_func=Lprim(mod_field toploop_getvalue_pos, - [Lprim(Pgetglobal toploop_ident, [], Loc_unknown)], + [Lprim(Pgetglobal toploop_unit, [], Loc_unknown)], Loc_unknown); ap_args=[Lconst(Const_base( Const_string (toplevel_name id, Location.none, None)))]; @@ -1577,7 +1599,7 @@ let toploop_setvalue id lam = Lapply{ ap_loc=Loc_unknown; ap_func=Lprim(mod_field toploop_setvalue_pos, - [Lprim(Pgetglobal toploop_ident, [], Loc_unknown)], + [Lprim(Pgetglobal toploop_unit, [], Loc_unknown)], Loc_unknown); ap_args= [Lconst(Const_base( @@ -1742,7 +1764,9 @@ let transl_toplevel_definition str = let get_component = function None -> Lconst const_unit - | Some id -> Lprim(Pgetglobal id, [], Loc_unknown) + | Some id -> + let cu = id |> compilation_unit_of_ident in + Lprim(Pgetglobal cu, [], Loc_unknown) let transl_package_flambda component_names coercion = let size = @@ -1763,7 +1787,7 @@ let transl_package component_names target_name coercion = let components = Lprim(Pmakeblock(0, Immutable, None, alloc_heap), List.map get_component component_names, Loc_unknown) in - Lprim(Psetglobal target_name, + Lprim(Psetglobal (target_name |> compilation_unit_of_ident), [apply_coercion Loc_unknown Strict coercion components], Loc_unknown) (* @@ -1783,6 +1807,7 @@ let transl_package component_names target_name coercion = *) let transl_store_package component_names target_name coercion = + let target_unit = target_name |> compilation_unit_of_ident in let rec make_sequence fn pos arg = match arg with [] -> lambda_unit @@ -1793,7 +1818,7 @@ let transl_store_package component_names target_name coercion = make_sequence (fun pos id -> Lprim(mod_setfield pos, - [Lprim(Pgetglobal target_name, [], Loc_unknown); + [Lprim(Pgetglobal target_unit, [], Loc_unknown); get_component id], Loc_unknown)) 0 component_names) @@ -1810,7 +1835,7 @@ let transl_store_package component_names target_name coercion = make_sequence (fun pos _id -> Lprim(mod_setfield pos, - [Lprim(Pgetglobal target_name, [], Loc_unknown); + [Lprim(Pgetglobal target_unit, [], Loc_unknown); Lprim(mod_field pos, [Lvar blk], Loc_unknown)], Loc_unknown)) 0 pos_cc_list)) diff --git a/lambda/translobj.mli b/lambda/translobj.mli index c27053e9611..cbe9ac81119 100644 --- a/lambda/translobj.mli +++ b/lambda/translobj.mli @@ -23,7 +23,7 @@ val meth: lambda -> string -> lambda * lambda list val reset_labels: unit -> unit val transl_label_init: (unit -> lambda * 'a) -> lambda * 'a val transl_store_label_init: - Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda + Compilation_unit.t -> int -> ('a -> lambda) -> 'a -> int * lambda val method_ids: Ident.Set.t ref (* reset when starting a new wrapper *) diff --git a/lambda/translprim.ml b/lambda/translprim.ml index 4750492883a..5e453afb7cc 100644 --- a/lambda/translprim.ml +++ b/lambda/translprim.ml @@ -815,7 +815,7 @@ let lambda_primitive_needs_event_after = function | Pbbswap _ | Pobj_dup -> true | Pidentity | Pbytes_to_string | Pbytes_of_string | Pignore | Psetglobal _ - | Pgetglobal _ | Pmakeblock _ | Pmakefloatblock _ + | Pgetglobal _ | Pgetpredef _ | Pmakeblock _ | Pmakefloatblock _ | Pfield _ | Pfield_computed _ | Psetfield _ | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Praise _ | Psequor | Psequand | Pnot | Pnegint | Paddint | Psubint | Pmulint diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml index 6684107ca36..0503df55ad9 100644 --- a/middle_end/closure/closure.ml +++ b/middle_end/closure/closure.ml @@ -1227,7 +1227,12 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = ap_specialised=Default_specialise; ap_probe=None; }) - | Lprim(Pgetglobal id, [], loc) -> + | Lprim(Pgetglobal cu, [], loc) -> + let id = Compilation_unit.to_global_ident_for_legacy_code cu in + let dbg = Debuginfo.from_location loc in + check_constant_result (getglobal dbg id) + (Compilenv.global_approx id) + | Lprim(Pgetpredef id, [], loc) -> let dbg = Debuginfo.from_location loc in check_constant_result (getglobal dbg id) (Compilenv.global_approx id) @@ -1237,11 +1242,12 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = check_constant_result (Uprim(P.Pfield n, [ulam], dbg)) (field_approx n approx) | Lprim(Psetfield(n, is_ptr, init), - [Lprim(Pgetglobal id, [], _); lam], loc) -> + [Lprim(Pgetglobal cu, [], _); lam], loc) -> let (ulam, approx) = close env lam in if approx <> Value_unknown then (!global_approx).(n) <- approx; let dbg = Debuginfo.from_location loc in + let id = cu |> Compilation_unit.to_global_ident_for_legacy_code in (Uprim(P.Psetfield(n, is_ptr, init), [getglobal dbg id; ulam], dbg), Value_unknown) | Lprim(Praise k, [arg], loc) -> diff --git a/middle_end/convert_primitives.ml b/middle_end/convert_primitives.ml index 7abfacaf8bc..9bb2477e069 100644 --- a/middle_end/convert_primitives.ml +++ b/middle_end/convert_primitives.ml @@ -164,6 +164,7 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive = | Pidentity | Pgetglobal _ | Psetglobal _ + | Pgetpredef _ -> Misc.fatal_errorf "lambda primitive %a can't be converted to \ clambda primitive" diff --git a/middle_end/flambda/closure_conversion.ml b/middle_end/flambda/closure_conversion.ml index 82b0c30bd57..d8141a04a26 100644 --- a/middle_end/flambda/closure_conversion.ml +++ b/middle_end/flambda/closure_conversion.ml @@ -475,22 +475,27 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = close t env (Lambda.Llet(Strict, Pgenval, Ident.create_local "dummy", arg, Lconst const)) - | Lprim (Pfield _, [Lprim (Pgetglobal id, [],_)], _) - when Ident.same id t.current_unit_id -> + | Lprim (Pfield _, [Lprim (Pgetglobal cu, [],_)], _) + when Ident.same (cu |> Compilation_unit.to_global_ident_for_legacy_code) + t.current_unit_id -> Misc.fatal_errorf "[Pfield (Pgetglobal ...)] for the current compilation \ unit is forbidden upon entry to the middle end" | Lprim (Psetfield (_, _, _), [Lprim (Pgetglobal _, [], _); _], _) -> Misc.fatal_errorf "[Psetfield (Pgetglobal ...)] is \ forbidden upon entry to the middle end" - | Lprim (Pgetglobal id, [], _) when Ident.is_predef id -> + | Lprim (Pgetpredef id, [], _) -> + assert (Ident.is_predef id); let symbol = Symbol.for_predef_ident id in t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols; name_expr (Symbol symbol) ~name:Names.predef_exn - | Lprim (Pgetglobal id, [], _) -> + | Lprim (Pgetglobal cu, [], _) -> + let id = cu |> Compilation_unit.to_global_ident_for_legacy_code in assert (not (Ident.same id t.current_unit_id)); - let symbol = - Symbol.for_global_or_predef_ident ((pack_prefix_for_global_ident t) id) id + let cu = + Compilation_unit.with_for_pack_prefix cu + (pack_prefix_for_global_ident t id) in + let symbol = Symbol.for_compilation_unit cu in t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols; name_expr (Symbol symbol) ~name:Names.pgetglobal | Lprim (lambda_p, args, loc) -> diff --git a/middle_end/internal_variable_names.ml b/middle_end/internal_variable_names.ml index d8a48332cdd..e045fbd4295 100644 --- a/middle_end/internal_variable_names.ml +++ b/middle_end/internal_variable_names.ml @@ -119,6 +119,7 @@ let pfloatcomp = "Pfloatcomp" let pfloatfield = "Pfloatfield" let pfloatofint = "Pfloatofint" let pgetglobal = "Pgetglobal" +let pgetpredef = "Pgetpredef" let pidentity = "Pidentity" let pignore = "Pignore" let pint_as_pointer = "Pint_as_pointer" @@ -225,6 +226,7 @@ let pfloatcomp_arg = "Pfloatcomp_arg" let pfloatfield_arg = "Pfloatfield_arg" let pfloatofint_arg = "Pfloatofint_arg" let pgetglobal_arg = "Pgetglobal_arg" +let pgetpredef_arg = "Pgetpredef_arg" let pobj_dup_arg = "Pobj_dup_arg" let pobj_magic_arg = "Pobj_magic_arg" let pidentity_arg = "Pidentity_arg" @@ -327,6 +329,7 @@ let of_primitive : Lambda.primitive -> string = function | Pdirapply _ -> pdirapply | Pgetglobal _ -> pgetglobal | Psetglobal _ -> psetglobal + | Pgetpredef _ -> pgetpredef | Pmakeblock _ -> pmakeblock | Pmakefloatblock _ -> pmakefloatblock | Pfield _ -> pfield @@ -437,6 +440,7 @@ let of_primitive_arg : Lambda.primitive -> string = function | Pdirapply _ -> pdirapply_arg | Pgetglobal _ -> pgetglobal_arg | Psetglobal _ -> psetglobal_arg + | Pgetpredef _ -> pgetpredef_arg | Pmakeblock _ -> pmakeblock_arg | Pmakefloatblock _ -> pmakefloatblock_arg | Pfield _ -> pfield_arg diff --git a/otherlibs/dynlink/dune b/otherlibs/dynlink/dune index f0f6006c16f..bd31a1411b2 100644 --- a/otherlibs/dynlink/dune +++ b/otherlibs/dynlink/dune @@ -205,6 +205,10 @@ ; at the moment, apparently Buenzli is working on this). ; We use a workaround for the moment. +; CR-someday lmaurer: This is a serious maintenance burden. *Surely* this +; list can be generated automatically and added to the dynlink.cma rule +; by a %{read} expression. + ; Deps within the compiler tree must be on dynlink_internal not dynlink. (library (name dynlink_internal) @@ -229,6 +233,7 @@ -ccopt %{read:natdynlinkops} -o dynlink.cma ; NOTE: Be sure to keep these arguments in dependency order! + .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Int_replace_polymorphic_compare.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Binutils.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Local_store.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Build_path_prefix_map.cmo @@ -245,6 +250,9 @@ .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Ident.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Longident.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Builtin_attributes.cmo + .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Compilation_unit.cmo + .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Linkage_name.cmo + .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Symbol.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Type_immediacy.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Path.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Attr_helper.cmo @@ -253,7 +261,6 @@ .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Syntaxerr.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Bytesections.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Cmi_format.cmo - .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Int_replace_polymorphic_compare.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Debuginfo.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Btype.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Consistbl.cmo @@ -273,9 +280,6 @@ .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Runtimedef.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Symtable.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Opcodes.cmo - .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Compilation_unit.cmo - .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Linkage_name.cmo - .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Symbol.cmo .dynlink_internal.objs/byte/dynlink_types.cmo .dynlink_internal.objs/byte/dynlink_platform_intf.cmo .dynlink_internal.objs/byte/dynlink_common.cmo @@ -293,6 +297,7 @@ -ccopt %{read:natdynlinkops} -o dynlink.cmxa ; NOTE: Be sure to keep these arguments in dependency order! + .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Int_replace_polymorphic_compare.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Binutils.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Local_store.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Build_path_prefix_map.cmx @@ -309,6 +314,9 @@ .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Ident.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Longident.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Builtin_attributes.cmx + .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Compilation_unit.cmx + .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Linkage_name.cmx + .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Symbol.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Type_immediacy.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Path.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Attr_helper.cmx @@ -317,7 +325,6 @@ .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Syntaxerr.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Bytesections.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Cmi_format.cmx - .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Int_replace_polymorphic_compare.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Debuginfo.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Btype.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Consistbl.cmx @@ -337,9 +344,6 @@ .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Runtimedef.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Symtable.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Opcodes.cmx - .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Compilation_unit.cmx - .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Linkage_name.cmx - .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Symbol.cmx .dynlink_internal.objs/native/dynlink_types.cmx .dynlink_internal.objs/native/dynlink_platform_intf.cmx .dynlink_internal.objs/native/dynlink_common.cmx diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml index 2ac70d1a36d..681ee3279c0 100644 --- a/toplevel/opttoploop.ml +++ b/toplevel/opttoploop.ml @@ -77,13 +77,18 @@ let toplevel_value id = try Ident.find_same id !remembered with _ -> Misc.fatal_error @@ "Unknown ident: " ^ Ident.unique_name id +let compilation_unit_of_toplevel_ident id = + Compilation_unit.create Compilation_unit.Prefix.empty + (Ident.name id |> Compilation_unit.Name.of_string) + let close_phrase lam = let open Lambda in Ident.Set.fold (fun id l -> let glb, pos = toplevel_value id in let glob = Lprim (mod_field pos, - [Lprim (Pgetglobal glb, [], Loc_unknown)], + [Lprim (Pgetglobal (glb |> compilation_unit_of_toplevel_ident), + [], Loc_unknown)], Loc_unknown) in Llet(Strict, Pgenval, id, glob, l) diff --git a/utils/compilation_unit.ml b/utils/compilation_unit.ml index 49e29068da0..ff6360700d1 100644 --- a/utils/compilation_unit.ml +++ b/utils/compilation_unit.ml @@ -196,6 +196,8 @@ let predef_exn = create Prefix.empty (Name.of_string "*predef*") 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 = { t with for_pack_prefix; } @@ -248,6 +250,9 @@ let print_name ppf t = let full_path_as_string t = Format.asprintf "%a" print t +let to_global_ident_for_legacy_code 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 "@[(\ diff --git a/utils/compilation_unit.mli b/utils/compilation_unit.mli index 72215ab9a14..f9662cebf8c 100644 --- a/utils/compilation_unit.mli +++ b/utils/compilation_unit.mli @@ -93,6 +93,12 @@ val create : Prefix.t -> Name.t -> t prefix is extracted if there is any. *) val of_string : string -> t +(** Create a global [Ident.t] representing this compilation unit. DO NOT USE + if you can possibly avoid it. Most uses of [Ident.t]s that are known to be + global should simply use [t] instead. *) +(* CR mshinwell: Delete this as soon as the functor packs work is finished. *) +val to_global_ident_for_legacy_code : t -> Ident.t + (** Find whether one compilation unit has another as a child. That is, whether the other unit has this one as its path prefix. *) val is_parent : t -> child:t -> bool @@ -106,6 +112,13 @@ val predef_exn : t (** The name of the compilation unit, excluding any [for_pack_prefix]. *) val name : t -> Name.t +(** The name of the compilation unit, excluding any [for_pack_prefix], as + as a string. *) + +(* CR mshinwell: Try to delete this as soon as the functor packs work is + finished. *) +val name_as_string : t -> string + (** The "-for-pack" prefix associated with the given compilation unit. *) val for_pack_prefix : t -> Prefix.t