Unboxed numbers (#1165)

Author: Ekdohibs

backend/cmm_helpers.ml

@@ -2658,6 +2658,10 @@ let machtype_of_layout (layout : Lambda.layout) =
   match layout with
   | 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 =
@@ -3998,4 +4002,6 @@ let kind_of_layout (layout : Lambda.layout) =
   | Ptop | Pbottom ->
     (* This is incorrect but only used for unboxing *)
     Vval Pgenval
+  | Punboxed_float -> Vfloat
+  | Punboxed_int _ -> Vint
   | Pvalue kind -> Vval kind

backend/cmmgen.ml

@@ -664,6 +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_int _ | Pbox_int _
          | Pbbswap _), _)
         ->
           fatal_error "Cmmgen.transl:prim"
@@ -806,6 +807,8 @@ 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_int _ ->
+           u := No_unboxing
          | Pvalue kind ->
            let strict = is_strict kind in
            u := join_unboxed_number_kind ~strict !u
@@ -817,12 +820,12 @@ and transl_catch (kind : Cmm.value_kind) env nfail ids body handler dbg =
   let body = transl env_body body in
   let new_env, rewrite, ids =
     List.fold_right
-      (fun (id, _kind, u) (env, rewrite, ids) ->
+      (fun (id, layout, u) (env, rewrite, ids) ->
          match !u with
          | No_unboxing | Boxed (_, true) | No_result ->
              env,
              (fun x -> x) :: rewrite,
-             (id, Cmm.typ_val) :: ids
+             (id, machtype_of_layout layout) :: ids
          | Boxed (bn, false) ->
              let unboxed_id = V.create_local (VP.name id) in
              add_unboxed_id (VP.var id) unboxed_id bn env,
@@ -937,7 +940,15 @@ and transl_prim_1 env p arg dbg =
       offsetint n (transl env arg) dbg
   | Poffsetref n ->
       offsetref n (transl env arg) dbg
+  | Punbox_int bi ->
+    transl_unbox_int dbg env bi arg
+  | Pbox_int (bi, m) ->
+    box_int dbg bi m (transl env arg)
   (* Floating-point operations *)
+  | Punbox_float ->
+      transl_unbox_float dbg env arg
+  | Pbox_float m ->
+      box_float dbg m (transl env arg)
   | Pfloatofint m ->
       box_float dbg m (Cop(Cfloatofint, [untag_int(transl env arg) dbg], dbg))
   | Pintoffloat ->
@@ -1172,6 +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_int _ | Pbox_int _
     ->
       fatal_errorf "Cmmgen.transl_prim_2: %a"
         Printclambda_primitives.primitive p
@@ -1232,6 +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_int _ | Pbox_int _
     ->
       fatal_errorf "Cmmgen.transl_prim_3: %a"
         Printclambda_primitives.primitive p
@@ -1305,6 +1318,16 @@ 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 | 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 ->
+        let typ = machtype_of_layout layout in
+        Clet_mut(id, typ, cexp, cbody)
+  end
   | Pvalue kind ->
     transl_let_value env str kind id exp transl_body
 

middle_end/clambda_primitives.ml

@@ -122,6 +122,10 @@ type primitive =
   | Popaque
   (* Probes *)
   | 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
@@ -144,6 +148,8 @@ and value_kind = Lambda.value_kind =
 and layout = Lambda.layout =
   | Ptop
   | Pvalue of value_kind
+  | Punboxed_float
+  | Punboxed_int of boxed_integer
   | Pbottom
 
 and block_shape = Lambda.block_shape
@@ -171,4 +177,8 @@ and raise_kind = Lambda.raise_kind =
 
 let equal (x: primitive) (y: primitive) = x = y
 
-let result_layout _p = Lambda.layout_any_value
+let result_layout (p : primitive) =
+  match p with
+  | Punbox_float -> Lambda.Punboxed_float
+  | Punbox_int bi -> Lambda.Punboxed_int bi
+  | _ -> Lambda.layout_any_value

middle_end/clambda_primitives.mli

@@ -125,6 +125,10 @@ type primitive =
   | Popaque
   (* Probes *)
   | 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 +151,8 @@ and value_kind = Lambda.value_kind =
 and layout = Lambda.layout =
   | Ptop
   | Pvalue of value_kind
+  | Punboxed_float
+  | Punboxed_int of boxed_integer
   | Pbottom
 
 and block_shape = Lambda.block_shape

middle_end/closure/closure.ml

@@ -61,6 +61,8 @@ let is_gc_ignorable kind =
   match kind with
   | 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
 

middle_end/convert_primitives.ml

@@ -154,6 +154,10 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive =
       ~native_name:"caml_obj_dup"
       ~native_repr_args:[P.Prim_global, P.Same_as_ocaml_repr]
       ~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

middle_end/flambda/closure_offsets.ml

@@ -77,6 +77,8 @@ let add_closure_offsets
           Misc.fatal_error
             "[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

middle_end/flambda/flambda_to_clambda.ml

@@ -703,6 +703,8 @@ and to_clambda_set_of_closures t env
           Misc.fatal_error
             "[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
@@ -752,7 +754,11 @@ and to_clambda_closed_set_of_closures t env symbol
     in
     let body =
       let body, body_layout = to_clambda t env_body function_decl.body in
-      assert(Lambda.compatible_layout body_layout function_decl.return_layout);
+      if not (Lambda.compatible_layout body_layout function_decl.return_layout) then
+        Misc.fatal_errorf "Incompatible layouts:@.body: %[email protected]: %a@.%a@."
+          Printlambda.layout body_layout
+          Printlambda.layout function_decl.return_layout
+          Printclambda.clambda body;
       Un_anf.apply ~ppf_dump:t.ppf_dump ~what:symbol body
     in
     assert (

middle_end/flambda2/from_lambda/closure_conversion.ml

@@ -693,7 +693,8 @@ 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 _ ->
+      | Pobj_magic _ | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _
+        ->
         (* Inconsistent with outer match *)
         assert false
     in

middle_end/flambda2/from_lambda/lambda_to_flambda.ml

@@ -953,7 +953,8 @@ let primitive_can_raise (prim : Lambda.primitive) =
   | Pbigstring_set_32 true
   | Pbigstring_set_64 true
   | Pctconst _ | Pbswap16 | Pbbswap _ | Pint_as_pointer | Popaque _
-  | Pprobe_is_enabled _ | Pobj_dup | Pobj_magic _ ->
+  | Pprobe_is_enabled _ | Pobj_dup | Pobj_magic _ | Pbox_float _ | Punbox_float
+  | Punbox_int _ | Pbox_int _ ->
     false
 
 let primitive_result_kind (prim : Lambda.primitive) :
@@ -1014,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
@@ -1035,6 +1037,13 @@ let primitive_result_kind (prim : Lambda.primitive) :
       (_, _, (Pbigarray_complex32 | Pbigarray_complex64 | Pbigarray_unknown), _)
   | Pint_as_pointer | Pobj_dup ->
     Flambda_kind.With_subkind.any_value
+  | 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

middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml

@@ -722,6 +722,22 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list)
          ( Float_comp (Yielding_bool (convert_float_comparison comp)),
            unbox_float arg1,
            unbox_float arg2 ))
+  | Punbox_float, [arg] -> Unary (Unbox_number Naked_float, arg)
+  | Pbox_float mode, [arg] ->
+    Unary
+      ( Box_number
+          ( Naked_float,
+            Alloc_mode.For_allocations.from_lambda mode ~current_region ),
+        arg )
+  | Punbox_int bi, [arg] ->
+    let kind = boxable_number_of_boxed_integer bi in
+    Unary (Unbox_number kind, arg)
+  | Pbox_int (bi, mode), [arg] ->
+    let kind = boxable_number_of_boxed_integer bi 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 }
@@ -1168,7 +1184,8 @@ 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 _ ),
+      | Pobj_magic _ | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _
+        ),
       ([] | _ :: _ :: _) ) ->
     Misc.fatal_errorf
       "Closure_conversion.convert_primitive: Wrong arity for unary primitive \

middle_end/flambda2/kinds/flambda_kind.ml

@@ -522,6 +522,10 @@ module With_subkind = struct
     | Ptop -> Misc.fatal_error "Can't convert layout [Ptop] to flambda kind"
     | 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

middle_end/internal_variable_names.ml

@@ -302,6 +302,14 @@ let unbox_free_vars_of_closures = "unbox_free_vars_of_closures"
 let unit = "unit"
 let zero = "zero"
 let probe_handler = "probe_handler"
+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
@@ -421,6 +429,10 @@ let of_primitive : Lambda.primitive -> string = function
   | Pprobe_is_enabled _ -> pprobe_is_enabled
   | Pobj_dup -> pobj_dup
   | 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
@@ -529,3 +541,7 @@ let of_primitive_arg : Lambda.primitive -> string = function
   | Pprobe_is_enabled _ -> pprobe_is_enabled_arg
   | Pobj_dup -> pobj_dup_arg
   | 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

middle_end/printclambda.ml

@@ -56,6 +56,10 @@ let layout (layout : Lambda.layout) =
   | Pvalue kind -> value_kind kind
   | 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

middle_end/printclambda_primitives.ml

@@ -230,3 +230,8 @@ let primitive ppf (prim:Clambda_primitives.primitive) =
   | Pint_as_pointer -> fprintf ppf "int_as_pointer"
   | Popaque -> fprintf ppf "opaque"
   | 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)

middle_end/semantics_of_primitives.ml

@@ -82,8 +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_int _
   | Pintoffloat
   | Pfloatcomp _ -> No_effects, No_coeffects
+  | Pbox_float m | Pbox_int (_, m)
   | Pfloatofint m
   | Pnegfloat m
   | Pabsfloat m
@@ -210,8 +212,10 @@ let may_locally_allocate (prim:Clambda_primitives.primitive) : bool =
     -> false
   | Poffsetint _ -> false
   | Poffsetref _ -> false
+  | Punbox_float | Punbox_int _
   | Pintoffloat
   | Pfloatcomp _ -> false
+  | Pbox_float m | Pbox_int (_, m)
   | Pfloatofint m
   | Pnegfloat m
   | Pabsfloat m

ocaml/asmcomp/cmm_helpers.ml

@@ -2243,6 +2243,10 @@ let machtype_of_layout (layout : Lambda.layout) =
   match layout with
   | 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 =
@@ -3149,4 +3153,6 @@ let kind_of_layout (layout : Lambda.layout) =
   | Ptop | Pbottom ->
     (* This is incorrect but only used for unboxing *)
     Vval Pgenval
+  | Punboxed_float -> Vfloat
+  | Punboxed_int _ -> Vint
   | Pvalue kind -> Vval kind