Allow unboxed float32s in mixed blocks (#2550)

Author: TheNumbat

backend/cmm_helpers.ml

@@ -1287,6 +1287,35 @@ let setfield_unboxed_int64_or_nativeint arr ofs newval dbg =
          [array_indexing log2_size_addr arr ofs dbg; newval],
          dbg ))
 
+(* Getters and setters for unboxed float32 fields *)
+
+let get_field_unboxed_float32 mutability ~block ~index dbg =
+  (* CR layouts v5.1: Properly support big-endian. *)
+  if Arch.big_endian
+  then
+    Misc.fatal_error
+      "Unboxed float32 fields only supported on little-endian architectures";
+  let memory_chunk = Single { reg = Float32 } in
+  (* CR layouts v5.1: We'll need to vary log2_size_addr to efficiently pack
+   * float32s *)
+  let field_address = array_indexing log2_size_addr block index dbg in
+  Cop
+    (Cload { memory_chunk; mutability; is_atomic = false }, [field_address], dbg)
+
+let setfield_unboxed_float32 arr ofs newval dbg =
+  (* CR layouts v5.1: Properly support big-endian. *)
+  if Arch.big_endian
+  then
+    Misc.fatal_error
+      "Unboxed float32 fields only supported on little-endian architectures";
+  (* CR layouts v5.1: We will need to vary log2_size_addr when float32 fields
+     are efficiently packed. *)
+  return_unit dbg
+    (Cop
+       ( Cstore (Single { reg = Float32 }, Assignment),
+         [array_indexing log2_size_addr arr ofs dbg; newval],
+         dbg ))
+
 (* String length *)
 
 (* Length of string block *)
@@ -1566,12 +1595,13 @@ let make_mixed_alloc ~mode dbg tag shape args =
       match flat_suffix.(idx - value_prefix_len) with
       | Imm -> int_array_set arr ofs newval dbg
       | Float | Float64 -> float_array_set arr ofs newval dbg
+      | Float32 -> setfield_unboxed_float32 arr ofs newval dbg
       | Bits32 -> setfield_unboxed_int32 arr ofs newval dbg
       | Bits64 | Word -> setfield_unboxed_int64_or_nativeint arr ofs newval dbg
   in
   let size =
-    (* CR layouts 5.1: When we pack int32s more efficiently, this code will need
-       to change. *)
+    (* CR layouts 5.1: When we pack int32s/float32s more efficiently, this code
+       will need to change. *)
     value_prefix_len + Array.length flat_suffix
   in
   if size_float <> size_addr

backend/cmm_helpers.mli

@@ -1006,7 +1006,8 @@ val unboxed_int64_or_nativeint_array_set :
   Debuginfo.t ->
   expression
 
-(** {2 Getters and setters for unboxed int fields of mixed blocks} *)
+(** {2 Getters and setters for unboxed int and float32 fields of mixed
+    blocks} *)
 
 (** The argument structure for getters is parallel to [get_field_computed]. *)
 
@@ -1017,6 +1018,13 @@ val get_field_unboxed_int32 :
   Debuginfo.t ->
   expression
 
+val get_field_unboxed_float32 :
+  Asttypes.mutable_flag ->
+  block:expression ->
+  index:expression ->
+  Debuginfo.t ->
+  expression
+
 val get_field_unboxed_int64_or_nativeint :
   Asttypes.mutable_flag ->
   block:expression ->
@@ -1032,4 +1040,6 @@ val get_field_unboxed_int64_or_nativeint :
 
 val setfield_unboxed_int32 : ternary_primitive
 
+val setfield_unboxed_float32 : ternary_primitive
+
 val setfield_unboxed_int64_or_nativeint : ternary_primitive

backend/selectgen.ml

@@ -206,8 +206,9 @@ let size_component : machtype_component -> int = function
   | Int -> Arch.size_int
   | Float -> Arch.size_float
   | Float32 ->
-    assert (Arch.size_float = 8);
-    Arch.size_float / 2
+    (* CR layouts v5.1: reconsider when float32 fields are efficiently packed.
+       Note that packed float32# arrays are handled via a separate path. *)
+    Arch.size_float
   | Vec128 -> Arch.size_vec128
 
 let size_machtype mty =
@@ -222,10 +223,11 @@ let size_expr (env:environment) exp =
       Cconst_int _ | Cconst_natint _ -> Arch.size_int
     | Cconst_symbol _ ->
         Arch.size_addr
-    | Cconst_float32 _ ->
-      assert (Arch.size_float = 8);
-      Arch.size_float / 2
     | Cconst_float _ -> Arch.size_float
+    | Cconst_float32 _ ->
+      (* CR layouts v5.1: reconsider when float32 fields are efficiently packed.
+         Note that packed float32# arrays are handled via a separate path. *)
+      Arch.size_float
     | Cconst_vec128 _ -> Arch.size_vec128
     | Cvar id ->
         begin try

middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml

@@ -991,8 +991,8 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
       List.mapi
         (fun i arg ->
           match Lambda.get_mixed_block_element shape i with
-          | Value_prefix | Flat_suffix (Float64 | Imm | Bits32 | Bits64 | Word)
-            ->
+          | Value_prefix
+          | Flat_suffix (Float64 | Float32 | Imm | Bits32 | Bits64 | Word) ->
             arg
           | Flat_suffix Float -> unbox_float arg)
         args
@@ -1533,7 +1533,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
     let value =
       match write with
       | Mwrite_value_prefix _
-      | Mwrite_flat_suffix (Imm | Float64 | Bits32 | Bits64 | Word) ->
+      | Mwrite_flat_suffix (Imm | Float64 | Float32 | Bits32 | Bits64 | Word) ->
         value
       | Mwrite_flat_suffix Float -> unbox_float value
     in

middle_end/flambda2/terms/code_size.ml

@@ -162,7 +162,8 @@ let block_set (kind : Flambda_primitive.Block_access_kind.t)
   | ( Mixed
         { field_kind =
             ( Value_prefix _
-            | Flat_suffix (Imm | Float | Float64 | Bits32 | Bits64 | Word) );
+            | Flat_suffix
+                (Imm | Float | Float64 | Float32 | Bits32 | Bits64 | Word) );
           _
         },
       (Assignment _ | Initialization) ) ->

middle_end/flambda2/terms/flambda_primitive.ml

@@ -63,6 +63,7 @@ module Mixed_block_flat_element = struct
     | Imm
     | Float
     | Float64
+    | Float32
     | Bits32
     | Bits64
     | Word
@@ -71,6 +72,7 @@ module Mixed_block_flat_element = struct
     | Imm -> Imm
     | Float -> Float
     | Float64 -> Float64
+    | Float32 -> Float32
     | Bits32 -> Bits32
     | Bits64 -> Bits64
     | Word -> Word
@@ -79,6 +81,7 @@ module Mixed_block_flat_element = struct
     | Imm -> Imm
     | Float -> Float
     | Float64 -> Float64
+    | Float32 -> Float32
     | Bits32 -> Bits32
     | Bits64 -> Bits64
     | Word -> Word
@@ -87,6 +90,7 @@ module Mixed_block_flat_element = struct
     | Imm -> "Imm"
     | Float -> "Float"
     | Float64 -> "Float64"
+    | Float32 -> "Float32"
     | Bits32 -> "Bits32"
     | Bits64 -> "Bits64"
     | Word -> "Word"
@@ -96,6 +100,7 @@ module Mixed_block_flat_element = struct
     | Imm, Imm
     | Float, Float
     | Float64, Float64
+    | Float32, Float32
     | Word, Word
     | Bits32, Bits32
     | Bits64, Bits64 ->
@@ -106,6 +111,8 @@ module Mixed_block_flat_element = struct
     | _, Float -> 1
     | Float64, _ -> -1
     | _, Float64 -> 1
+    | Float32, _ -> -1
+    | _, Float32 -> 1
     | Word, _ -> -1
     | _, Word -> 1
     | Bits32, _ -> -1
@@ -116,6 +123,7 @@ module Mixed_block_flat_element = struct
   let element_kind = function
     | Imm -> K.value
     | Float | Float64 -> K.naked_float
+    | Float32 -> K.naked_float32
     | Bits32 -> K.naked_int32
     | Bits64 -> K.naked_int64
     | Word -> K.naked_nativeint
@@ -532,6 +540,7 @@ module Block_access_kind = struct
       match field_kind with
       | Imm -> K.With_subkind.tagged_immediate
       | Float | Float64 -> K.With_subkind.naked_float
+      | Float32 -> K.With_subkind.naked_float32
       | Bits32 -> K.With_subkind.naked_int32
       | Bits64 -> K.With_subkind.naked_int64
       | Word -> K.With_subkind.naked_nativeint)

middle_end/flambda2/terms/flambda_primitive.mli

@@ -67,6 +67,7 @@ module Mixed_block_flat_element : sig
     | Imm
     | Float
     | Float64
+    | Float32
     | Bits32
     | Bits64
     | Word

middle_end/flambda2/to_cmm/to_cmm_primitive.ml

@@ -111,6 +111,7 @@ let block_load ~dbg (kind : P.Block_access_kind.t) (mutability : Mutability.t)
       (* CR layouts v5.1: We should use the mutability here to generate better
          code if the load is immutable. *)
       C.unboxed_float_array_ref block index dbg
+    | Float32 -> C.get_field_unboxed_float32 mutability ~block ~index dbg
     | Bits32 -> C.get_field_unboxed_int32 mutability ~block ~index dbg
     | Bits64 | Word ->
       C.get_field_unboxed_int64_or_nativeint mutability ~block ~index dbg)
@@ -132,6 +133,7 @@ let block_set ~dbg (kind : P.Block_access_kind.t) (init : P.Init_or_assign.t)
       | Imm ->
         C.setfield_computed Immediate init_or_assign block index new_value dbg
       | Float | Float64 -> C.float_array_set block index new_value dbg
+      | Float32 -> C.setfield_unboxed_float32 block index new_value dbg
       | Bits32 -> C.setfield_unboxed_int32 block index new_value dbg
       | Bits64 | Word ->
         C.setfield_unboxed_int64_or_nativeint block index new_value dbg)

ocaml/lambda/lambda.ml

@@ -343,7 +343,7 @@ and block_shape =
   value_kind list option
 
 and flat_element = Types.flat_element =
-    Imm | Float | Float64 | Bits32 | Bits64 | Word
+    Imm | Float | Float64 | Float32 | Bits32 | Bits64 | Word
 and flat_element_read =
   | Flat_read of flat_element (* invariant: not [Float] *)
   | Flat_read_float of alloc_mode
@@ -1249,7 +1249,7 @@ let get_mixed_block_element = Types.get_mixed_product_element
 let flat_read_non_float flat_element =
   match flat_element with
   | Float -> Misc.fatal_error "flat_element_read_non_float Float"
-  | Imm | Float64 | Bits32 | Bits64 | Word as flat_element ->
+  | Imm | Float64 | Float32 | Bits32 | Bits64 | Word as flat_element ->
       Flat_read flat_element
 
 let flat_read_float alloc_mode = Flat_read_float alloc_mode
@@ -1789,6 +1789,7 @@ let layout_of_mixed_field (kind : mixed_block_read) =
       match proj with
       | Imm -> layout_int
       | Float64 -> layout_unboxed_float Pfloat64
+      | Float32 -> layout_unboxed_float Pfloat32
       | Bits32 -> layout_unboxed_int32
       | Bits64 -> layout_unboxed_int64
       | Word -> layout_unboxed_nativeint

ocaml/lambda/lambda.mli

@@ -351,7 +351,7 @@ and block_shape =
   value_kind list option
 
 and flat_element = Types.flat_element =
-    Imm | Float | Float64 | Bits32 | Bits64 | Word
+    Imm | Float | Float64 | Float32 | Bits32 | Bits64 | Word
 and flat_element_read = private
   | Flat_read of flat_element (* invariant: not [Float] *)
   | Flat_read_float of alloc_mode

ocaml/lambda/matching.ml

@@ -2183,7 +2183,7 @@ let get_expr_args_record ~scopes head (arg, _mut, sort, layout) rem =
               else
                 let read =
                   match flat_suffix.(pos - value_prefix_len) with
-                  | Imm | Float64 | Bits32 | Bits64 | Word as non_float ->
+                  | Imm | Float64 | Float32 | Bits32 | Bits64 | Word as non_float ->
                       flat_read_non_float non_float
                   | Float ->
                       (* TODO: could optimise to Alloc_local sometimes *)

ocaml/lambda/translcore.ml

@@ -55,10 +55,7 @@ let layout_pat sort p = layout p.pat_env p.pat_loc sort p.pat_type
 
 let check_record_field_sort loc sort =
   match Jkind.Sort.get_default_value sort with
-  | Value | Float64 | Bits32 | Bits64 | Word -> ()
-  | Float32 ->
-    (* CR mslater: (float32) float32# records *)
-    Misc.fatal_error "Found unboxed float32 record field."
+  | Value | Float64 | Float32 | Bits32 | Bits64 | Word -> ()
   | Void -> raise (Error (loc, Illegal_void_record_field))
 
 (* Forward declaration -- to be filled in by Translmod.transl_module *)