Unboxed int, internals

ocaml-flambda · mshinwell · Mar 10, 2023 · Mar 2, 2023 · Mar 2, 2023 · Mar 2, 2023
commit 76401959e45e4bcd4cc548b8af5fefd3172fcc41
diff --git a/backend/cmm_helpers.ml b/backend/cmm_helpers.ml
@@ -2659,6 +2659,9 @@ let machtype_of_layout (layout : Lambda.layout) =
   | Ptop -> Misc.fatal_error "No machtype for layout [Ptop]"
   | Pbottom -> Misc.fatal_error "No unique machtype for layout [Pbottom]"
   | Punboxed_float -> typ_float
+  | Punboxed_int _ ->
+    (* Only 64-bit architectures, so this is always [typ_int] *)
+    typ_int
   | Pvalue _ -> typ_val
 
 let final_curry_function nlocal arity result =
@@ -4000,4 +4003,5 @@ let kind_of_layout (layout : Lambda.layout) =
     (* This is incorrect but only used for unboxing *)
     Vval Pgenval
   | Punboxed_float -> Vfloat
+  | Punboxed_int _ -> Vint
   | Pvalue kind -> Vval kind
diff --git a/backend/cmmgen.ml b/backend/cmmgen.ml
@@ -664,7 +664,7 @@ let rec transl env e =
          | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _
          | Pasrbint _ | Pbintcomp (_, _) | Pstring_load _ | Pbytes_load _
          | Pbytes_set _ | Pbigstring_load _ | Pbigstring_set _
-         | Punbox_float | Pbox_float _
+         | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _
          | Pbbswap _), _)
         ->
           fatal_error "Cmmgen.transl:prim"
@@ -807,7 +807,7 @@ and transl_catch (kind : Cmm.value_kind) env nfail ids body handler dbg =
            Misc.fatal_errorf
              "Variable %a with layout [Pbottom] can't be compiled"
              VP.print id
-         | Punboxed_float ->
+         | Punboxed_float | Punboxed_int _ ->
            failwith "TODO transl_catch"
          | Pvalue kind ->
            let strict = is_strict kind in
@@ -945,6 +945,10 @@ and transl_prim_1 env p arg dbg =
       transl_unbox_float dbg env arg
   | Pbox_float m ->
       box_float dbg m (transl env arg)
+  | Punbox_int bi ->
+      transl_unbox_int dbg env bi arg
+  | Pbox_int (bi, m) ->
+      box_int dbg bi m (transl env arg)
   | Pfloatofint m ->
       box_float dbg m (Cop(Cfloatofint, [untag_int(transl env arg) dbg], dbg))
   | Pintoffloat ->
@@ -1179,7 +1183,7 @@ and transl_prim_2 env p arg1 arg2 dbg =
   | Pnegbint _ | Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _)
   | Pbigarraydim _ | Pbytes_set _ | Pbigstring_set _ | Pbbswap _
   | Pprobe_is_enabled _
-  | Punbox_float | Pbox_float _
+  | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _
     ->
       fatal_errorf "Cmmgen.transl_prim_2: %a"
         Printclambda_primitives.primitive p
@@ -1240,7 +1244,7 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg =
   | Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _) | Pbigarraydim _
   | Pstring_load _ | Pbytes_load _ | Pbigstring_load _ | Pbbswap _
   | Pprobe_is_enabled _
-  | Punbox_float | Pbox_float _
+  | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _
     ->
       fatal_errorf "Cmmgen.transl_prim_3: %a"
         Printclambda_primitives.primitive p
@@ -1314,14 +1318,21 @@ and transl_let env str (layout : Lambda.layout) id exp transl_body =
        there may be constant closures inside that need lifting out. *)
     let _cbody : expression = transl_body env in
     cexp
-  | Punboxed_float -> begin
+  | Punboxed_float | Punboxed_int _ -> begin
       let cexp = transl env exp in
       let cbody = transl_body env in
       match str with
       | (Immutable | Immutable_unique) ->
         Clet(id, cexp, cbody)
       | Mutable ->
-        Clet_mut(id, typ_float, cexp, cbody)
+        let typ = match layout with
+          | Punboxed_float -> typ_float
+          | Punboxed_int (Pint32 | Pnativeint) -> typ_int
+          | Punboxed_int Pint64 -> typ_int64
+          | Ptop | Pbottom | Pvalue _ ->
+            assert false (* inconsistent with outer match *)
+        in
+        Clet_mut(id, typ, cexp, cbody)
   end
   | Pvalue kind ->
     transl_let_value env str kind id exp transl_body

diff --git a/middle_end/clambda_primitives.ml b/middle_end/clambda_primitives.ml
@@ -124,6 +124,8 @@ type primitive =
   | Pprobe_is_enabled of { name : string }
   | Punbox_float
   | Pbox_float of alloc_mode
+  | Punbox_int of boxed_integer
+  | Pbox_int of boxed_integer * alloc_mode
 
 and integer_comparison = Lambda.integer_comparison =
     Ceq | Cne | Clt | Cgt | Cle | Cge
@@ -147,6 +149,7 @@ and layout = Lambda.layout =
   | Ptop
   | Pvalue of value_kind
   | Punboxed_float
+  | Punboxed_int of boxed_integer
   | Pbottom
 
 and block_shape = Lambda.block_shape

diff --git a/middle_end/clambda_primitives.mli b/middle_end/clambda_primitives.mli
@@ -127,6 +127,8 @@ type primitive =
   | Pprobe_is_enabled of { name : string }
   | Punbox_float
   | Pbox_float of alloc_mode
+  | Punbox_int of boxed_integer
+  | Pbox_int of boxed_integer * alloc_mode
 
 and integer_comparison = Lambda.integer_comparison =
     Ceq | Cne | Clt | Cgt | Cle | Cge
@@ -150,6 +152,7 @@ and layout = Lambda.layout =
   | Ptop
   | Pvalue of value_kind
   | Punboxed_float
+  | Punboxed_int of boxed_integer
   | Pbottom
 
 and block_shape = Lambda.block_shape

diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml
@@ -62,6 +62,7 @@ let is_gc_ignorable kind =
   | Ptop -> Misc.fatal_error "[Ptop] can't be stored in a closure."
   | Pbottom -> Misc.fatal_error "[Pbottom] should not be stored in a closure."
   | Punboxed_float -> true
+  | Punboxed_int _ -> true
   | Pvalue Pintval -> true
   | Pvalue (Pgenval | Pfloatval | Pboxedintval _ | Pvariant _ | Parrayval _) -> false
 

diff --git a/middle_end/convert_primitives.ml b/middle_end/convert_primitives.ml
@@ -156,6 +156,8 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive =
       ~native_repr_res:(P.Prim_global, P.Same_as_ocaml_repr))
   | Punbox_float -> Punbox_float
   | Pbox_float m -> Pbox_float m
+  | Punbox_int bi -> Punbox_int bi
+  | Pbox_int (bi, m) -> Pbox_int (bi, m)
   | Pobj_magic _
   | Pbytes_to_string
   | Pbytes_of_string

diff --git a/middle_end/flambda/closure_offsets.ml b/middle_end/flambda/closure_offsets.ml
@@ -78,6 +78,7 @@ let add_closure_offsets
             "[Pbottom] should have been eliminated as dead code \
              and not stored in a closure."
         | Punboxed_float -> true
+        | Punboxed_int _ -> true
         | Pvalue Pintval -> true
         | Pvalue _ -> false)
       free_vars

diff --git a/middle_end/flambda/flambda_to_clambda.ml b/middle_end/flambda/flambda_to_clambda.ml
@@ -704,6 +704,7 @@ and to_clambda_set_of_closures t env
             "[Pbottom] should have been eliminated as dead code \
              and not stored in a closure."
         | Punboxed_float -> true
+        | Punboxed_int _ -> true
         | Pvalue Pintval -> true
         | Pvalue _ -> false)
       free_vars

diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml
@@ -693,7 +693,7 @@ let close_primitive acc env ~let_bound_var named (prim : Lambda.primitive) ~args
       | 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 _ | Punbox_float | Pbox_float _ ->
+      | Pobj_magic _ | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _ ->
         (* Inconsistent with outer match *)
         assert false
     in

diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml
@@ -954,7 +954,7 @@ let primitive_can_raise (prim : Lambda.primitive) =
   | Pbigstring_set_64 true
   | Pctconst _ | Pbswap16 | Pbbswap _ | Pint_as_pointer | Popaque _
   | Pprobe_is_enabled _ | Pobj_dup | Pobj_magic _
-  | Pbox_float _ | Punbox_float ->
+  | Pbox_float _ | Punbox_float | Punbox_int _ | Pbox_int _ ->
     false
 
 let primitive_result_kind (prim : Lambda.primitive) :
@@ -1015,7 +1015,8 @@ let primitive_result_kind (prim : Lambda.primitive) :
   | Pmulbint (bi, _)
   | Pbintofint (bi, _)
   | Pcvtbint (_, bi, _)
-  | Pbbswap (bi, _) -> (
+  | Pbbswap (bi, _)
+  | Pbox_int (bi, _) -> (
     match bi with
     | Pint32 -> Flambda_kind.With_subkind.boxed_int32
     | Pint64 -> Flambda_kind.With_subkind.boxed_int64
@@ -1039,6 +1040,11 @@ let primitive_result_kind (prim : Lambda.primitive) :
   | Pbox_float _ -> Flambda_kind.With_subkind.boxed_float
   | Punbox_float ->
     Flambda_kind.With_subkind.naked_float
+  | Punbox_int bi ->
+    match bi with
+    | Pint32 -> Flambda_kind.With_subkind.naked_int32
+    | Pint64 -> Flambda_kind.With_subkind.naked_int64
+    | Pnativeint -> Flambda_kind.With_subkind.naked_nativeint
 
 type cps_continuation =
   | Tail of Continuation.t

diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml
@@ -730,6 +730,26 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list)
           ( Flambda_kind.Boxable_number.Naked_float,
             Alloc_mode.For_allocations.from_lambda mode ~current_region ),
         arg )
+  | Punbox_int bi, [arg] ->
+    let kind =
+      Flambda_kind.Boxable_number.(
+        match bi with
+        | Pint32 -> Naked_int32
+        | Pint64 -> Naked_int64
+        | Pnativeint -> Naked_nativeint
+      )
+    in
+    Unary (Unbox_number kind, arg)
+  | Pbox_int (bi, mode), [arg] ->
+    let kind =
+      Flambda_kind.Boxable_number.(
+        match bi with
+        | Pint32 -> Naked_int32
+        | Pint64 -> Naked_int64
+        | Pnativeint -> Naked_nativeint
+      )
+    in
+    Unary (Box_number (kind, Alloc_mode.For_allocations.from_lambda mode ~current_region), arg)
   | Pfield_computed sem, [obj; field] ->
     let block_access : P.Block_access_kind.t =
       Values { tag = Unknown; size = Unknown; field_kind = Any_value }
@@ -1176,7 +1196,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list)
       | Pintofbint _ | Pnegbint _ | Popaque _ | Pduprecord _ | Parraylength _
       | Pduparray _ | Pfloatfield _ | Pcvtbint _ | Poffsetref _ | Pbswap16
       | Pbbswap _ | Pisint _ | Pint_as_pointer | Pbigarraydim _ | Pobj_dup
-      | Pobj_magic _ | Punbox_float | Pbox_float _ ),
+      | Pobj_magic _ | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _),
       ([] | _ :: _ :: _) ) ->
     Misc.fatal_errorf
       "Closure_conversion.convert_primitive: Wrong arity for unary primitive \

diff --git a/middle_end/flambda2/kinds/flambda_kind.ml b/middle_end/flambda2/kinds/flambda_kind.ml
@@ -523,6 +523,9 @@ module With_subkind = struct
     | Pbottom ->
       Misc.fatal_error "Can't convert layout [Pbottom] to flambda kind"
     | Punboxed_float -> naked_float
+    | Punboxed_int Pint32 -> naked_int32
+    | Punboxed_int Pint64 -> naked_int64
+    | Punboxed_int Pnativeint -> naked_nativeint
 
   include Container_types.Make (struct
     type nonrec t = t

diff --git a/middle_end/internal_variable_names.ml b/middle_end/internal_variable_names.ml
@@ -306,6 +306,10 @@ let punbox_float = "Punbox_float"
 let pbox_float = "Pbox_float"
 let punbox_float_arg = "Punbox_float_arg"
 let pbox_float_arg = "Pbox_float_arg"
+let punbox_int = "Punbox_int"
+let pbox_int = "Pbox_int"
+let punbox_int_arg = "Punbox_int_arg"
+let pbox_int_arg = "Pbox_int_arg"
 
 let anon_fn_with_loc (sloc: Lambda.scoped_location) =
   let loc = Debuginfo.Scoped_location.to_location sloc in
@@ -427,6 +431,8 @@ let of_primitive : Lambda.primitive -> string = function
   | Pobj_magic _ -> pobj_magic
   | Punbox_float -> punbox_float
   | Pbox_float _ -> pbox_float
+  | Punbox_int _ -> punbox_int
+  | Pbox_int _ -> pbox_int
 
 let of_primitive_arg : Lambda.primitive -> string = function
   | Pbytes_of_string -> pbytes_of_string_arg
@@ -537,3 +543,5 @@ let of_primitive_arg : Lambda.primitive -> string = function
   | Pobj_magic _ -> pobj_magic_arg
   | Punbox_float -> punbox_float_arg
   | Pbox_float _ -> pbox_float_arg
+  | Punbox_int _ -> punbox_int_arg
+  | Pbox_int _ -> pbox_int_arg
diff --git a/middle_end/printclambda.ml b/middle_end/printclambda.ml
@@ -57,6 +57,9 @@ let layout (layout : Lambda.layout) =
   | Ptop -> ":top"
   | Pbottom -> ":bottom"
   | Punboxed_float -> ":unboxed_float"
+  | Punboxed_int Pint32 -> ":unboxed_int32"
+  | Punboxed_int Pint64 -> ":unboxed_int64"
+  | Punboxed_int Pnativeint -> ":unboxed_nativeint"
 
 let rec structured_constant ppf = function
   | Uconst_float x -> fprintf ppf "%F" x

diff --git a/middle_end/printclambda_primitives.ml b/middle_end/printclambda_primitives.ml
@@ -232,3 +232,6 @@ let primitive ppf (prim:Clambda_primitives.primitive) =
   | Pprobe_is_enabled {name} -> fprintf ppf "probe_is_enabled[%s]" name
   | Pbox_float m -> fprintf ppf "box_float.%s" (alloc_kind m)
   | Punbox_float -> fprintf ppf "unbox_float"
+  | Pbox_int (bi, m) ->
+    fprintf ppf "box_%s.%s" (boxed_integer_name bi) (alloc_kind m)
+  | Punbox_int bi -> fprintf ppf "unbox_%s" (boxed_integer_name bi)
diff --git a/middle_end/semantics_of_primitives.ml b/middle_end/semantics_of_primitives.ml
@@ -82,10 +82,10 @@ let for_primitive (prim : Clambda_primitives.primitive) =
       Arbitrary_effects, No_coeffects
   | Poffsetint _ -> No_effects, No_coeffects
   | Poffsetref _ -> Arbitrary_effects, Has_coeffects
-  | Punbox_float
+  | Punbox_float | Punbox_int _
   | Pintoffloat
   | Pfloatcomp _ -> No_effects, No_coeffects
-  | Pbox_float m
+  | Pbox_float m | Pbox_int (_, m)
   | Pfloatofint m
   | Pnegfloat m
   | Pabsfloat m
@@ -212,10 +212,10 @@ let may_locally_allocate (prim:Clambda_primitives.primitive) : bool =
     -> false
   | Poffsetint _ -> false
   | Poffsetref _ -> false
-  | Punbox_float
+  | Punbox_float | Punbox_int _
   | Pintoffloat
   | Pfloatcomp _ -> false
-  | Pbox_float m
+  | Pbox_float m | Pbox_int (_, m)
   | Pfloatofint m
   | Pnegfloat m
   | Pabsfloat m

diff --git a/ocaml/bytecomp/bytegen.ml b/ocaml/bytecomp/bytegen.ml
@@ -121,7 +121,7 @@ let preserve_tailcall_for_prim = function
   | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint
   | Pasrint | Pintcomp _ | Poffsetint _ | Poffsetref _ | Pintoffloat
   | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ | Pmulfloat _
-  | Punbox_float | Pbox_float _
+  | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _
   | Pdivfloat _ | Pfloatcomp _ | Pstringlength | Pstringrefu  | Pstringrefs
   | Pcompare_ints | Pcompare_floats | Pcompare_bints _
   | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
@@ -531,7 +531,7 @@ let comp_primitive p args =
   | Pmakeblock _
   | Pmakefloatblock _
   | Pprobe_is_enabled _
-  | Punbox_float | Pbox_float _
+  | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _
     ->
       fatal_error "Bytegen.comp_primitive"
 

diff --git a/ocaml/lambda/lambda.ml b/ocaml/lambda/lambda.ml
@@ -241,6 +241,8 @@ type primitive =
   | Pobj_magic of layout
   | Punbox_float
   | Pbox_float of alloc_mode
+  | Punbox_int of boxed_integer
+  | Pbox_int of boxed_integer * alloc_mode
 
 and integer_comparison =
     Ceq | Cne | Clt | Cgt | Cle | Cge
@@ -260,6 +262,7 @@ and layout =
   | Ptop
   | Pvalue of value_kind
   | Punboxed_float
+  | Punboxed_int of boxed_integer
   | Pbottom
 
 and block_shape =
@@ -334,10 +337,11 @@ let compatible_layout x y =
   | _, Pbottom -> true
   | Pvalue _, Pvalue _ -> true
   | Punboxed_float, Punboxed_float -> true
-  | Punboxed_float, Pvalue _
-  | Pvalue _, Punboxed_float -> false
+  | Punboxed_int bi1, Punboxed_int bi2 ->
+      equal_boxed_integer bi1 bi2
   | Ptop, Ptop -> true
   | Ptop, _ | _, Ptop -> false
+  | (Pvalue _ | Punboxed_float | Punboxed_int _), _ -> false
 
 let must_be_value layout =
   match layout with
@@ -1376,8 +1380,8 @@ let primitive_may_allocate : primitive -> alloc_mode option = function
   | Pprobe_is_enabled _ -> None
   | Pobj_dup -> Some alloc_heap
   | Pobj_magic _ -> None
-  | Punbox_float -> None
-  | Pbox_float m -> Some m
+  | Punbox_float | Punbox_int _ -> None
+  | Pbox_float m | Pbox_int (_, m) -> Some m
 
 let constant_layout = function
   | Const_int _ | Const_char _ -> Pvalue Pintval
@@ -1438,8 +1442,9 @@ let primitive_result_layout (p : primitive) =
   | Pmulbint (bi, _) | Pdivbint {size = bi} | Pmodbint {size = bi}
   | Pandbint (bi, _) | Porbint (bi, _) | Pxorbint (bi, _)
   | Plslbint (bi, _) | Plsrbint (bi, _) | Pasrbint (bi, _)
-  | Pbbswap (bi, _) ->
+  | Pbbswap (bi, _) | Pbox_int (bi, _) ->
       layout_boxedint bi
+  | Punbox_int bi -> Punboxed_int bi
   | Pstring_load_32 _ | Pbytes_load_32 _ | Pbigstring_load_32 _ ->
       layout_boxedint Pint32
   | Pstring_load_64 _ | Pbytes_load_64 _ | Pbigstring_load_64 _ ->

diff --git a/ocaml/lambda/lambda.mli b/ocaml/lambda/lambda.mli
@@ -192,6 +192,8 @@ type primitive =
   | Pobj_magic of layout
   | Punbox_float
   | Pbox_float of alloc_mode
+  | Punbox_int of boxed_integer
+  | Pbox_int of boxed_integer * alloc_mode
 
 and integer_comparison =
     Ceq | Cne | Clt | Cgt | Cle | Cge
@@ -217,6 +219,7 @@ and layout =
   | Ptop
   | Pvalue of value_kind
   | Punboxed_float
+  | Punboxed_int of boxed_integer
   | Pbottom
 
 and block_shape =