flambda-backend: Float blocks

bytecomp/bytegen.ml

@@ -112,7 +112,8 @@ let preserve_tailcall_for_prim = function
     Pidentity | Popaque | Pdirapply | Prevapply | Psequor | Psequand ->
       true
   | Pbytes_to_string | Pbytes_of_string | Pignore | Pgetglobal _ | Psetglobal _
-  | Pmakeblock _ | Pfield _ | Pfield_computed | Psetfield _
+  | Pmakeblock _ | Pmakefloatblock _
+  | Pfield _ | Pfield_computed | Psetfield _
   | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Pduprecord _
   | Pccall _ | Praise _ | Pnot | Pnegint | Paddint | Psubint | Pmulint
   | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint
@@ -210,7 +211,8 @@ let rec size_of_lambda env = function
   | Lprim(Pmakeblock _, args, _) -> RHS_block (List.length args)
   | Lprim (Pmakearray ((Paddrarray|Pintarray), _), args, _) ->
       RHS_block (List.length args)
-  | Lprim (Pmakearray (Pfloatarray, _), args, _) ->
+  | Lprim (Pmakearray (Pfloatarray, _), args, _)
+  | Lprim (Pmakefloatblock _, args, _) ->
       RHS_floatblock (List.length args)
   | Lprim (Pmakearray (Pgenarray, _), _, _) ->
      (* Pgenarray is excluded from recursive bindings by the
@@ -736,6 +738,9 @@ let rec comp_expr env exp sz cont =
         (Kpush::
          Kconst (Const_base (Const_int n))::
          Kaddint::cont)
+  | Lprim (Pmakefloatblock _mut, args, loc) ->
+      let cont = add_pseudo_event loc !compunit_name cont in
+      comp_args env args sz (Kmakefloatblock (List.length args) :: cont)
   | Lprim(Pmakearray (kind, _), args, loc) ->
       let cont = add_pseudo_event loc !compunit_name cont in
       begin match kind with

bytecomp/symtable.ml

@@ -232,7 +232,7 @@ let rec transl_const = function
         (fun c -> Obj.set_field block !pos (transl_const c); incr pos)
         fields;
       block
-  | Const_float_array fields ->
+  | Const_float_block fields | Const_float_array fields ->
       let res = Array.Floatarray.create (List.length fields) in
       List.iteri (fun i f -> Array.Floatarray.set res i (float_of_string f))
         fields;

lambda/lambda.ml

@@ -51,6 +51,7 @@ type primitive =
   | Psetglobal of Ident.t
   (* Operations on heap blocks *)
   | Pmakeblock of int * mutable_flag * block_shape
+  | Pmakefloatblock of mutable_flag
   | Pfield of int
   | Pfield_computed
   | Psetfield of int * immediate_or_pointer * initialization_or_assignment
@@ -212,6 +213,7 @@ type structured_constant =
   | Const_block of int * structured_constant list
   | Const_float_array of string list
   | Const_immstring of string
+  | Const_float_block of string list
 
 type tailcall_attribute =
   | Tailcall_expectation of bool

lambda/lambda.mli

@@ -57,6 +57,7 @@ type primitive =
   | Psetglobal of Ident.t
   (* Operations on heap blocks *)
   | Pmakeblock of int * mutable_flag * block_shape
+  | Pmakefloatblock of mutable_flag
   | Pfield of int
   | Pfield_computed
   | Psetfield of int * immediate_or_pointer * initialization_or_assignment
@@ -203,6 +204,7 @@ type structured_constant =
   | Const_block of int * structured_constant list
   | Const_float_array of string list
   | Const_immstring of string
+  | Const_float_block of string list
 
 type tailcall_attribute =
   | Tailcall_expectation of bool

lambda/printlambda.ml

@@ -35,6 +35,12 @@ let rec struct_const ppf = function
       let sconsts ppf scl =
         List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl in
       fprintf ppf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl
+  | Const_float_block [] ->
+      fprintf ppf "[|b |]"
+  | Const_float_block (f1 :: fl) ->
+      let floats ppf fl =
+        List.iter (fun f -> fprintf ppf "@ %s" f) fl in
+      fprintf ppf "@[<1>[|b@[%s%a@]|]@]" f1 floats fl
   | Const_float_array [] ->
       fprintf ppf "[| |]"
   | Const_float_array (f1 :: fl) ->
@@ -159,6 +165,8 @@ let primitive ppf = function
       fprintf ppf "makeblock %i%a" tag block_shape shape
   | Pmakeblock(tag, Mutable, shape) ->
       fprintf ppf "makemutable %i%a" tag block_shape shape
+  | Pmakefloatblock Immutable -> fprintf ppf "makefloatblock Immutable"
+  | Pmakefloatblock Mutable -> fprintf ppf "makefloatblock Mutable"
   | Pfield n -> fprintf ppf "field %i" n
   | Pfield_computed -> fprintf ppf "field_computed"
   | Psetfield(n, ptr, init) ->
@@ -355,6 +363,7 @@ let name_of_primitive = function
   | Pgetglobal _ -> "Pgetglobal"
   | Psetglobal _ -> "Psetglobal"
   | Pmakeblock _ -> "Pmakeblock"
+  | Pmakefloatblock _ -> "Pmakefloatblock"
   | Pfield _ -> "Pfield"
   | Pfield_computed -> "Pfield_computed"
   | Psetfield _ -> "Psetfield"

lambda/translcore.ml

@@ -1032,7 +1032,7 @@ and transl_record ~scopes loc env fields repres opt_init_expr =
         | Record_inlined tag -> Lconst(Const_block(tag, cl))
         | Record_unboxed _ -> Lconst(match cl with [v] -> v | _ -> assert false)
         | Record_float ->
-            Lconst(Const_float_array(List.map extract_float cl))
+            Lconst(Const_float_block(List.map extract_float cl))
         | Record_extension _ ->
             raise Not_constant
       with Not_constant ->
@@ -1044,7 +1044,7 @@ and transl_record ~scopes loc env fields repres opt_init_expr =
             Lprim(Pmakeblock(tag, mut, Some shape), ll, loc)
         | Record_unboxed _ -> (match ll with [v] -> v | _ -> assert false)
         | Record_float ->
-            Lprim(Pmakearray (Pfloatarray, mut), ll, loc)
+            Lprim(Pmakefloatblock mut, ll, loc)
         | Record_extension path ->
             let slot = transl_extension_path loc env path in
             Lprim(Pmakeblock(0, mut, Some (Pgenval :: shape)), slot :: ll, loc)

lambda/translprim.ml

@@ -760,7 +760,8 @@ let lambda_primitive_needs_event_after = function
   | Pbbswap _ -> true
 
   | Pidentity | Pbytes_to_string | Pbytes_of_string | Pignore | Psetglobal _
-  | Pgetglobal _ | Pmakeblock _ | Pfield _ | Pfield_computed | Psetfield _
+  | Pgetglobal _ | Pmakeblock _ | Pmakefloatblock _
+  | Pfield _ | Pfield_computed | Psetfield _
   | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Praise _
   | Psequor | Psequand | Pnot | Pnegint | Paddint | Psubint | Pmulint
   | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint

middle_end/closure/closure.ml

@@ -895,6 +895,9 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam =
         | Const_base(Const_char c) -> Uconst_int (Char.code c)
         | Const_block (tag, fields) ->
             str (Uconst_block (tag, List.map transl fields))
+        | Const_float_block sl ->
+            (* CR mshinwell: Add [Uconst_float_block]? *)
+            str (Uconst_float_array (List.map float_of_string sl))
         | Const_float_array sl ->
             (* constant float arrays are really immutable *)
             str (Uconst_float_array (List.map float_of_string sl))

middle_end/convert_primitives.ml

@@ -26,6 +26,8 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive =
   match prim with
   | Pmakeblock (tag, mutability, shape) ->
       Pmakeblock (tag, mutability, shape)
+  | Pmakefloatblock mutability ->
+      Pmakearray (Pfloatarray, mutability)
   | Pfield field -> Pfield field
   | Pfield_computed -> Pfield_computed
   | Psetfield (field, imm_or_pointer, init_or_assign) ->

middle_end/flambda/closure_conversion.ml

@@ -141,7 +141,7 @@ let rec declare_const t (const : Lambda.structured_constant)
   | Const_immstring c ->
     register_const t (Allocated_const (Immutable_string c))
       Names.const_immstring
-  | Const_float_array c ->
+  | Const_float_array c | Const_float_block c ->
     register_const t
       (Allocated_const (Immutable_float_array (List.map float_of_string c)))
       Names.const_float_array

middle_end/flambda/simplify_primitives.ml

@@ -123,6 +123,7 @@ let primitive (p : Clambda_primitives.primitive) (args, approxs)
   | Pmakearray(_, _) when is_empty approxs ->
     Prim (Pmakeblock(0, Asttypes.Immutable, Some []), [], dbg),
     A.value_block (Tag.create_exn 0) [||], C.Benefit.zero
+  (* CR mshinwell: Work out what to do here with [Pmakefloatblock] *)
   | Pmakearray (Pfloatarray, Mutable) ->
       let approx =
         A.value_mutable_float_array ~size:(List.length args)

middle_end/internal_variable_names.ml

@@ -136,6 +136,7 @@ let plsrbint = "Plsrbint"
 let plsrint = "Plsrint"
 let pmakearray = "Pmakearray"
 let pmakeblock = "Pmakeblock"
+let pmakefloatblock = "Pmakefloatblock"
 let pmodbint = "Pmodbint"
 let pmodint = "Pmodint"
 let pmulbint = "Pmulbint"
@@ -239,6 +240,7 @@ let plsrbint_arg = "Plsrbint_arg"
 let plsrint_arg = "Plsrint_arg"
 let pmakearray_arg = "Pmakearray_arg"
 let pmakeblock_arg = "Pmakeblock_arg"
+let pmakefloatblock_arg = "Pmakefloatblock_arg"
 let pmodbint_arg = "Pmodbint_arg"
 let pmodint_arg = "Pmodint_arg"
 let pmulbint_arg = "Pmulbint_arg"
@@ -322,6 +324,7 @@ let of_primitive : Lambda.primitive -> string = function
   | Pgetglobal _ -> pgetglobal
   | Psetglobal _ -> psetglobal
   | Pmakeblock _ -> pmakeblock
+  | Pmakefloatblock _ -> pmakefloatblock
   | Pfield _ -> pfield
   | Pfield_computed -> pfield_computed
   | Psetfield _ -> psetfield
@@ -429,6 +432,7 @@ let of_primitive_arg : Lambda.primitive -> string = function
   | Pgetglobal _ -> pgetglobal_arg
   | Psetglobal _ -> psetglobal_arg
   | Pmakeblock _ -> pmakeblock_arg
+  | Pmakefloatblock _ -> pmakefloatblock_arg
   | Pfield _ -> pfield_arg
   | Pfield_computed -> pfield_computed_arg
   | Psetfield _ -> psetfield_arg

testsuite/tests/translprim/ref_spec.compilers.reference

@@ -17,7 +17,7 @@
          cst_rec = (makemutable 0 0 0)
          gen_rec = (makemutable 0 0 0)
          flt_rec = (makemutable 0 (*,float) 0 0.)
-         flt_rec' = (makearray[float] 0. 0.))
+         flt_rec' = (makefloatblock Mutable 0. 0.))
         (seq (setfield_imm 1 int_rec 2) (setfield_imm 1 var_rec 66)
           (setfield_ptr 1 vargen_rec [0: 66 0])
           (setfield_ptr 1 vargen_rec 67) (setfield_imm 1 cst_rec 1)

tools/dumpobj.ml

@@ -103,6 +103,10 @@ let rec print_struct_const = function
           List.iter (fun a -> printf ", "; print_struct_const a) al;
           printf ")"
       end
+  | Const_float_block a ->
+      printf "[|b ";
+      List.iter (fun f -> print_float f; printf "; ") a;
+      printf "|]"
   | Const_float_array a ->
       printf "[|";
       List.iter (fun f -> print_float f; printf "; ") a;