flambda-backend: Have Lambda Pgetglobal and Psetglobal take `Comp…

…ilation_unit.t` (ocaml-flambda#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 <mshinwell@pm.me>

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)

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

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

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"

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

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

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

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

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"

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

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