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 <mshinwell@pm.me>

middle_end/closure/closure.ml

@@ -1225,7 +1225,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)
@@ -1235,11 +1240,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

@@ -480,22 +480,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/flambda2/from_lambda/closure_conversion.ml

@@ -585,12 +585,16 @@ let close_primitive acc env ~let_bound_var named (prim : Lambda.primitive) ~args
     in
     close_c_call acc env ~loc ~let_bound_var prim ~args exn_continuation dbg
       ~current_region k
-  | Pgetglobal id, [] ->
-    let is_predef_exn = Ident.is_predef id in
-    if not (is_predef_exn || not (Ident.same id (Env.current_unit_id env)))
+  | Pgetglobal cu, [] ->
+    let id = cu |> Compilation_unit.to_global_ident_for_legacy_code in
+    if Ident.same id (Env.current_unit_id env)
     then
-      Misc.fatal_errorf "Non-predef Pgetglobal %a in the same unit" Ident.print
-        id;
+      Misc.fatal_errorf "Pgetglobal %a in the same unit" Compilation_unit.print
+        cu;
+    let acc, simple = symbol_for_ident acc env id in
+    let named = Named.create_simple simple in
+    k acc (Some named)
+  | Pgetpredef id, [] ->
     let acc, simple = symbol_for_ident acc env id in
     let named = Named.create_simple simple in
     k acc (Some named)
@@ -638,28 +642,28 @@ let close_primitive acc env ~let_bound_var named (prim : Lambda.primitive) ~args
       | Pmakearray (_, _, _mode) ->
         register_const0 acc Static_const.empty_array "empty_array"
       | Pidentity | Pbytes_to_string | Pbytes_of_string | Pignore | Prevapply _
-      | Pdirapply _ | Pgetglobal _ | Psetglobal _ | Pfield _ | Pfield_computed _
-      | Psetfield _ | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _
-      | Pduprecord _ | Pccall _ | Praise _ | Psequand | Psequor | Pnot | Pnegint
-      | Paddint | Psubint | Pmulint | Pdivint _ | Pmodint _ | Pandint | Porint
-      | Pxorint | Plslint | Plsrint | Pasrint | Pintcomp _ | Pcompare_ints
-      | Pcompare_floats | Pcompare_bints _ | Poffsetint _ | Poffsetref _
-      | Pintoffloat | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ | Paddfloat _
-      | Psubfloat _ | Pmulfloat _ | Pdivfloat _ | Pfloatcomp _ | Pstringlength
-      | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytessetu
-      | Pbytesrefs | Pbytessets | Pduparray _ | Parraylength _ | Parrayrefu _
-      | Parraysetu _ | Parrayrefs _ | Parraysets _ | Pisint _ | Pisout
-      | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _ | Paddbint _
-      | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _
-      | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _
-      | Pbintcomp _ | Pbigarrayref _ | Pbigarrayset _ | Pbigarraydim _
-      | Pstring_load_16 _ | Pstring_load_32 _ | Pstring_load_64 _
-      | Pbytes_load_16 _ | Pbytes_load_32 _ | Pbytes_load_64 _ | Pbytes_set_16 _
-      | Pbytes_set_32 _ | Pbytes_set_64 _ | Pbigstring_load_16 _
-      | Pbigstring_load_32 _ | Pbigstring_load_64 _ | Pbigstring_set_16 _
-      | Pbigstring_set_32 _ | Pbigstring_set_64 _ | Pctconst _ | Pbswap16
-      | Pbbswap _ | Pint_as_pointer | Popaque | Pprobe_is_enabled _ | Pobj_dup
-      | Pobj_magic ->
+      | Pdirapply _ | Pgetglobal _ | Psetglobal _ | Pgetpredef _ | Pfield _
+      | Pfield_computed _ | Psetfield _ | Psetfield_computed _ | Pfloatfield _
+      | Psetfloatfield _ | Pduprecord _ | Pccall _ | Praise _ | Psequand
+      | Psequor | Pnot | Pnegint | Paddint | Psubint | Pmulint | Pdivint _
+      | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint
+      | Pintcomp _ | Pcompare_ints | Pcompare_floats | Pcompare_bints _
+      | Poffsetint _ | Poffsetref _ | Pintoffloat | Pfloatofint _ | Pnegfloat _
+      | Pabsfloat _ | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _
+      | Pfloatcomp _ | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength
+      | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets | Pduparray _
+      | Parraylength _ | Parrayrefu _ | Parraysetu _ | Parrayrefs _
+      | Parraysets _ | Pisint _ | Pisout | Pbintofint _ | Pintofbint _
+      | Pcvtbint _ | Pnegbint _ | Paddbint _ | Psubbint _ | Pmulbint _
+      | Pdivbint _ | Pmodbint _ | Pandbint _ | Porbint _ | Pxorbint _
+      | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp _ | Pbigarrayref _
+      | Pbigarrayset _ | Pbigarraydim _ | Pstring_load_16 _ | Pstring_load_32 _
+      | Pstring_load_64 _ | Pbytes_load_16 _ | Pbytes_load_32 _
+      | Pbytes_load_64 _ | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_64 _
+      | Pbigstring_load_16 _ | Pbigstring_load_32 _ | Pbigstring_load_64 _
+      | Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_64 _
+      | Pctconst _ | Pbswap16 | Pbbswap _ | Pint_as_pointer | Popaque
+      | Pprobe_is_enabled _ | Pobj_dup | Pobj_magic ->
         (* Inconsistent with outer match *)
         assert false
     in

middle_end/flambda2/from_lambda/lambda_to_flambda.ml

@@ -621,8 +621,10 @@ let transform_primitive env (prim : L.primitive) args loc =
       }
     in
     Transformed (L.Lapply apply)
-  | Pfield _, [L.Lprim (Pgetglobal id, [], _)]
-    when Ident.same id (Env.current_unit_id env) ->
+  | Pfield _, [L.Lprim (Pgetglobal cu, [], _)]
+    when Ident.same
+           (cu |> Compilation_unit.to_global_ident_for_legacy_code)
+           (Env.current_unit_id env) ->
     Misc.fatal_error
       "[Pfield (Pgetglobal ...)] for the current compilation unit is forbidden \
        upon entry to the middle end"
@@ -874,18 +876,18 @@ let primitive_can_raise (prim : Lambda.primitive) =
   | Pbigarrayset (_, _, _, Pbigarray_unknown_layout) ->
     true
   | Pidentity | Pbytes_to_string | Pbytes_of_string | Pignore | Prevapply _
-  | Pdirapply _ | Pgetglobal _ | Psetglobal _ | Pmakeblock _ | Pmakefloatblock _
-  | Pfield _ | Pfield_computed _ | Psetfield _ | Psetfield_computed _
-  | Pfloatfield _ | Psetfloatfield _ | Pduprecord _ | Psequand | Psequor | Pnot
-  | Pnegint | Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint | Plslint
-  | Plsrint | Pasrint | Pintcomp _ | Pcompare_ints | Pcompare_floats
-  | Pcompare_bints _ | Poffsetint _ | Poffsetref _ | Pintoffloat | Pfloatofint _
-  | Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ | Pmulfloat _
-  | Pdivfloat _ | Pfloatcomp _ | Pstringlength | Pstringrefu | Pbyteslength
-  | Pbytesrefu | Pbytessetu | Pmakearray _ | Pduparray _ | Parraylength _
-  | Parrayrefu _ | Parraysetu _ | Pisint _ | Pisout | Pbintofint _
-  | Pintofbint _ | Pcvtbint _ | Pnegbint _ | Paddbint _ | Psubbint _
-  | Pmulbint _
+  | Pdirapply _ | Pgetglobal _ | Psetglobal _ | Pgetpredef _ | Pmakeblock _
+  | Pmakefloatblock _ | Pfield _ | Pfield_computed _ | Psetfield _
+  | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Pduprecord _
+  | Psequand | Psequor | Pnot | Pnegint | Paddint | Psubint | Pmulint | Pandint
+  | Porint | Pxorint | Plslint | Plsrint | Pasrint | Pintcomp _ | Pcompare_ints
+  | Pcompare_floats | Pcompare_bints _ | Poffsetint _ | Poffsetref _
+  | Pintoffloat | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ | Paddfloat _
+  | Psubfloat _ | Pmulfloat _ | Pdivfloat _ | Pfloatcomp _ | Pstringlength
+  | Pstringrefu | Pbyteslength | Pbytesrefu | Pbytessetu | Pmakearray _
+  | Pduparray _ | Parraylength _ | Parrayrefu _ | Parraysetu _ | Pisint _
+  | Pisout | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _ | Paddbint _
+  | Psubbint _ | Pmulbint _
   | Pdivbint { is_safe = Unsafe; _ }
   | Pmodbint { is_safe = Unsafe; _ }
   | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _

middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml

@@ -1203,7 +1203,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list)
     Misc.fatal_errorf
       "[%a] should have been removed by [Lambda_to_flambda.transform_primitive]"
       Printlambda.primitive prim
-  | Pgetglobal _, _ ->
+  | Pgetglobal _, _ | Pgetpredef _, _ ->
     Misc.fatal_errorf
       "[%a] should have been handled by [Closure_conversion.close_primitive]"
       Printlambda.primitive prim

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

native_toplevel/opttoploop.ml

@@ -108,13 +108,18 @@ let toplevel_value id =
   try Ident.find_same id !remembered
   with _ -> failwith ("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)

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

ocaml/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

ocaml/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

ocaml/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"