flambda-backend: Unboxed numbers (#1165)

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

asmcomp/cmmgen.ml

@@ -606,6 +606,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"
@@ -750,6 +751,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 =
              match kind with
@@ -765,12 +768,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,
@@ -883,7 +886,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 ->
@@ -1118,6 +1129,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
@@ -1178,6 +1190,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
@@ -1263,6 +1276,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
 

bytecomp/bytegen.ml

@@ -121,6 +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_int _ | Pbox_int _
   | Pdivfloat _ | Pfloatcomp _ | Pstringlength | Pstringrefu  | Pstringrefs
   | Pcompare_ints | Pcompare_floats | Pcompare_bints _
   | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
@@ -530,6 +531,7 @@ let comp_primitive p args =
   | Pmakeblock _
   | Pmakefloatblock _
   | Pprobe_is_enabled _
+  | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _
     ->
       fatal_error "Bytegen.comp_primitive"
 
@@ -705,6 +707,10 @@ let rec comp_expr env exp sz cont =
       end
   | Lprim((Popaque _ | Pobj_magic _), [arg], _) ->
       comp_expr env arg sz cont
+  | Lprim((Pbox_float _ | Punbox_float), [arg], _) ->
+      comp_expr env arg sz cont
+  | Lprim((Pbox_int _ | Punbox_int _), [arg], _) ->
+      comp_expr env arg sz cont
   | Lprim(Pignore, [arg], _) ->
       comp_expr env arg sz (add_const_unit cont)
   | Lprim(Pnot, [arg], _) ->

lambda/lambda.ml

@@ -239,6 +239,10 @@ type primitive =
   (* Primitives for [Obj] *)
   | Pobj_dup
   | 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
@@ -257,6 +261,8 @@ and value_kind =
 and layout =
   | Ptop
   | Pvalue of value_kind
+  | Punboxed_float
+  | Punboxed_int of boxed_integer
   | Pbottom
 
 and block_shape =
@@ -330,8 +336,12 @@ let compatible_layout x y =
   | Pbottom, _
   | _, Pbottom -> true
   | Pvalue _, Pvalue _ -> true
+  | Punboxed_float, Punboxed_float -> true
+  | 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
@@ -1372,6 +1382,8 @@ let primitive_may_allocate : primitive -> alloc_mode option = function
   | Pprobe_is_enabled _ -> None
   | Pobj_dup -> Some alloc_heap
   | Pobj_magic _ -> None
+  | Punbox_float | Punbox_int _ -> None
+  | Pbox_float m | Pbox_int (_, m) -> Some m
 
 let constant_layout = function
   | Const_int _ | Const_char _ -> Pvalue Pintval
@@ -1400,7 +1412,9 @@ let primitive_result_layout (p : primitive) =
   | Pduparray _ | Pbigarraydim _ | Pobj_dup -> layout_block
   | Pfield _ | Pfield_computed _ -> layout_field
   | Pfloatfield _ | Pfloatofint _ | Pnegfloat _ | Pabsfloat _
-  | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _ -> layout_float
+  | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _
+  | Pbox_float _ -> layout_float
+  | Punbox_float -> Punboxed_float
   | Pccall _p ->
       (* CR ncourant: use native_repr *)
       layout_any_value
@@ -1430,8 +1444,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 _ ->

lambda/lambda.mli

@@ -190,6 +190,10 @@ type primitive =
   (* Primitives for [Obj] *)
   | Pobj_dup
   | 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
@@ -214,6 +218,8 @@ and value_kind =
 and layout =
   | Ptop
   | Pvalue of value_kind
+  | Punboxed_float
+  | Punboxed_int of boxed_integer
   | Pbottom
 
 and block_shape =

lambda/printlambda.ml

@@ -100,6 +100,8 @@ let layout ppf layout =
   | Pvalue k -> value_kind ppf k
   | Ptop -> fprintf ppf "[top]"
   | Pbottom -> fprintf ppf "[bottom]"
+  | Punboxed_float -> fprintf ppf "[unboxed_float]"
+  | Punboxed_int bi -> fprintf ppf "[unboxed_%s]" (boxed_integer_name bi)
 
 let return_kind ppf (mode, kind) =
   let smode = alloc_mode mode in
@@ -113,6 +115,8 @@ let return_kind ppf (mode, kind) =
   | Pvalue (Pboxedintval bi) -> fprintf ppf ": %s%s@ " smode (boxed_integer_name bi)
   | Pvalue (Pvariant { consts; non_consts; }) ->
     variant_kind value_kind' ppf ~consts ~non_consts
+  | Punboxed_float -> fprintf ppf ": unboxed_float@ "
+  | Punboxed_int bi -> fprintf ppf ": unboxed_%s@ " (boxed_integer_name bi)
   | Ptop -> fprintf ppf ": top@ "
   | Pbottom -> fprintf ppf ": bottom@ "
 
@@ -447,6 +451,11 @@ let primitive ppf = function
   | Pprobe_is_enabled {name} -> fprintf ppf "probe_is_enabled[%s]" name
   | Pobj_dup -> fprintf ppf "obj_dup"
   | Pobj_magic _ -> fprintf ppf "obj_magic"
+  | Punbox_float -> fprintf ppf "unbox_float"
+  | Pbox_float m -> fprintf ppf "box_float%s" (alloc_kind m)
+  | Punbox_int bi -> fprintf ppf "unbox_%s" (boxed_integer_name bi)
+  | Pbox_int (bi, m) ->
+      fprintf ppf "box_%s%s" (boxed_integer_name bi) (alloc_kind m)
 
 let name_of_primitive = function
   | Pbytes_of_string -> "Pbytes_of_string"
@@ -555,6 +564,10 @@ let name_of_primitive = 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 check_attribute ppf check =
   let check_property = function

lambda/tmc.ml

@@ -880,6 +880,8 @@ let rec choice ctx t =
     | Pisint _ | Pisout
     | Pignore
     | Pcompare_ints | Pcompare_floats | Pcompare_bints _
+    | Punbox_float | Pbox_float _
+    | Punbox_int _ | Pbox_int _
 
     (* we don't handle array indices as destinations yet *)
     | (Pmakearray _ | Pduparray _)

lambda/translprim.ml

@@ -857,6 +857,7 @@ let lambda_primitive_needs_event_after = function
      collect the call stack. *)
   | Pduprecord _ | Pccall _ | Pfloatofint _ | Pnegfloat _ | Pabsfloat _
   | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _ | Pstringrefs | Pbytesrefs
+  | Pbox_float _ | Pbox_int _
   | Pbytessets | Pmakearray (Pgenarray, _, _) | Pduparray _
   | Parrayrefu (Pgenarray | Pfloatarray) | Parraysetu (Pgenarray | Pfloatarray)
   | Parrayrefs _ | Parraysets _ | Pbintofint _ | Pcvtbint _ | Pnegbint _
@@ -883,7 +884,7 @@ let lambda_primitive_needs_event_after = function
   | Parraylength _ | Parrayrefu _ | Parraysetu _ | Pisint _ | Pisout
   | Pprobe_is_enabled _
   | Pintofbint _ | Pctconst _ | Pbswap16 | Pint_as_pointer | Popaque _
-  | Pobj_magic _ -> false
+  | Pobj_magic _ | Punbox_float | Punbox_int _  -> false
 
 (* Determine if a primitive should be surrounded by an "after" debug event *)
 let primitive_needs_event_after = function

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

@@ -701,6 +701,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
@@ -750,7 +752,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: %a@.function: %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
     let label =