squash

Author: TheNumbat

backend/cmm_helpers.ml

@@ -1025,6 +1025,22 @@ let custom_ops_unboxed_int32_odd_array =
         Cconst_int (Config.custom_ops_struct_size, Debuginfo.none) ],
       Debuginfo.none )
 
+(* caml_unboxed_float32_array_ops refers to the first element of an array of two
+   custom ops. The array index indicates the number of (invalid) tailing
+   float32s (0 or 1). *)
+let custom_ops_unboxed_float32_array =
+  Cconst_symbol
+    (Cmm.global_symbol "caml_unboxed_float32_array_ops", Debuginfo.none)
+
+let custom_ops_unboxed_float32_even_array = custom_ops_unboxed_float32_array
+
+let custom_ops_unboxed_float32_odd_array =
+  Cop
+    ( Caddi,
+      [ custom_ops_unboxed_float32_array;
+        Cconst_int (Config.custom_ops_struct_size, Debuginfo.none) ],
+      Debuginfo.none )
+
 let custom_ops_unboxed_int64_array =
   Cconst_symbol
     (Cmm.global_symbol "caml_unboxed_int64_array_ops", Debuginfo.none)
@@ -1033,7 +1049,8 @@ let custom_ops_unboxed_nativeint_array =
   Cconst_symbol
     (Cmm.global_symbol "caml_unboxed_nativeint_array_ops", Debuginfo.none)
 
-let unboxed_int32_array_length arr dbg =
+let unboxed_packed_array_length arr dbg ~custom_ops_base_symbol
+    ~elements_per_word =
   (* Checking custom_ops is needed to determine if the array contains an odd or
      even number of elements *)
   let res =
@@ -1054,17 +1071,27 @@ let unboxed_int32_array_length arr dbg =
                   ( VP.create custom_ops_index_var,
                     (* compute index into custom ops array *)
                     lsr_int
-                      (sub_int (Cvar custom_ops_var)
-                         custom_ops_unboxed_int32_array dbg)
+                      (sub_int (Cvar custom_ops_var) custom_ops_base_symbol dbg)
                       (int ~dbg custom_ops_size_log2)
                       dbg,
                     (* subtract index from length in int32s *)
                     sub_int
-                      (mul_int (Cvar num_words_var) (int ~dbg 2) dbg)
+                      (mul_int (Cvar num_words_var)
+                         (int ~dbg elements_per_word)
+                         dbg)
                       (Cvar custom_ops_index_var) dbg ) ) ))
   in
   tag_int res dbg
 
+let unboxed_int32_array_length =
+  unboxed_packed_array_length
+    ~custom_ops_base_symbol:custom_ops_unboxed_int32_array ~elements_per_word:2
+
+let unboxed_float32_array_length =
+  unboxed_packed_array_length
+    ~custom_ops_base_symbol:custom_ops_unboxed_float32_array
+    ~elements_per_word:2
+
 let unboxed_int64_or_nativeint_array_length arr dbg =
   let res =
     bind "arr" arr (fun arr ->
@@ -1179,24 +1206,31 @@ let sign_extend_32 dbg e =
         [Cop (Clsl, [e; Cconst_int (32, dbg)], dbg); Cconst_int (32, dbg)],
         dbg )
 
-let unboxed_int32_array_ref arr index dbg =
+let unboxed_packed_array_ref arr index dbg ~memory_chunk ~elements_per_word =
   bind "arr" arr (fun arr ->
       bind "index" index (fun index ->
           let index =
-            (* Need to skip the custom_operations field. We add 2 element
-               offsets not 1 since the call to [array_indexing], below, is in
-               terms of 32-bit words. Then we multiply the offset by 2 to get 4
-               since we are manipulating a tagged int. *)
-            add_int index (int ~dbg 4) dbg
+            (* Need to skip the custom_operations field. We add
+               elements_per_word offsets not 1 since the call to
+               [array_indexing], below, is in terms of elements. Then we
+               multiply the offset by 2 since we are manipulating a tagged
+               int. *)
+            add_int index (int ~dbg (elements_per_word * 2)) dbg
           in
           let log2_size_addr = 2 in
-          (* N.B. The resulting value will be sign extended by the code
-             generated for a [Thirtytwo_signed] load. *)
           Cop
-            ( mk_load_mut Thirtytwo_signed,
+            ( mk_load_mut memory_chunk,
               [array_indexing log2_size_addr arr index dbg],
               dbg )))
 
+let unboxed_int32_array_ref =
+  unboxed_packed_array_ref ~memory_chunk:Thirtytwo_signed ~elements_per_word:2
+
+let unboxed_float32_array_ref =
+  unboxed_packed_array_ref
+    ~memory_chunk:(Single { reg = Float32 })
+    ~elements_per_word:2
+
 let unboxed_int64_or_nativeint_array_ref arr index dbg =
   bind "arr" arr (fun arr ->
       bind "index" index (fun index ->
@@ -1207,20 +1241,29 @@ let unboxed_int64_or_nativeint_array_ref arr index dbg =
           in
           int_array_ref arr index dbg))
 
-let unboxed_int32_array_set arr ~index ~new_value dbg =
+let unboxed_packed_array_set arr ~index ~new_value dbg ~memory_chunk
+    ~elements_per_word =
   bind "arr" arr (fun arr ->
       bind "index" index (fun index ->
           bind "new_value" new_value (fun new_value ->
               let index =
-                (* See comment in [unboxed_int32_array_ref]. *)
-                add_int index (int ~dbg 4) dbg
+                (* See comment in [unboxed_packed_array_ref]. *)
+                add_int index (int ~dbg (elements_per_word * 2)) dbg
               in
               let log2_size_addr = 2 in
               Cop
-                ( Cstore (Thirtytwo_signed, Assignment),
+                ( Cstore (memory_chunk, Assignment),
                   [array_indexing log2_size_addr arr index dbg; new_value],
                   dbg ))))
 
+let unboxed_int32_array_set =
+  unboxed_packed_array_set ~memory_chunk:Thirtytwo_signed ~elements_per_word:2
+
+let unboxed_float32_array_set =
+  unboxed_packed_array_set
+    ~memory_chunk:(Single { reg = Float32 })
+    ~elements_per_word:2
+
 let unboxed_int64_or_nativeint_array_set arr ~index ~new_value dbg =
   bind "arr" arr (fun arr ->
       bind "index" index (fun index ->
@@ -1258,6 +1301,14 @@ let get_field_unboxed_int32 mutability ~block ~index dbg =
   Cop
     (Cload { memory_chunk; mutability; is_atomic = false }, [field_address], dbg)
 
+let get_field_unboxed_float32 mutability ~block ~index dbg =
+  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 get_field_unboxed_int64_or_nativeint mutability ~block ~index dbg =
   let memory_chunk = Word_int in
   let field_address = array_indexing log2_size_addr block index dbg in
@@ -1280,6 +1331,15 @@ let setfield_unboxed_int32 arr ofs newval dbg =
          [array_indexing log2_size_addr arr ofs dbg; newval],
          dbg ))
 
+let setfield_unboxed_float32 arr ofs newval dbg =
+  (* 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 ))
+
 let setfield_unboxed_int64_or_nativeint arr ofs newval dbg =
   return_unit dbg
     (Cop
@@ -3076,9 +3136,7 @@ let arraylength kind arg dbg =
     (* Note: we only support 64 bit targets now, so this is ok for
        Punboxedfloatarray *)
     Cop (Cor, [float_array_length_shifted hdr dbg; Cconst_int (1, dbg)], dbg)
-  | Punboxedfloatarray Pfloat32 ->
-    (* CR mslater: (float32) unboxed arrays *)
-    assert false
+  | Punboxedfloatarray Pfloat32 -> unboxed_float32_array_length arg dbg
   | Punboxedintarray Pint64 | Punboxedintarray Pnativeint ->
     unboxed_int64_or_nativeint_array_length arg dbg
   | Punboxedintarray Pint32 -> unboxed_int32_array_length arg dbg
@@ -4006,6 +4064,22 @@ let allocate_unboxed_int32_array ~elements (mode : Lambda.alloc_mode) dbg =
   in
   Cop (Calloc mode, Cconst_natint (header, dbg) :: custom_ops :: payload, dbg)
 
+let allocate_unboxed_float32_array ~elements (mode : Lambda.alloc_mode) dbg =
+  let header =
+    let size = 1 (* custom_ops field *) + ((List.length elements + 1) / 2) in
+    match mode with
+    | Alloc_heap -> custom_header ~size
+    | Alloc_local -> custom_local_header ~size
+  in
+  let custom_ops =
+    (* For odd-length unboxed float32 arrays there are 32 bits spare at the end
+       of the block, which are never read. *)
+    if List.length elements mod 2 = 0
+    then custom_ops_unboxed_float32_even_array
+    else custom_ops_unboxed_float32_odd_array
+  in
+  Cop (Calloc mode, Cconst_natint (header, dbg) :: custom_ops :: elements, dbg)
+
 let allocate_unboxed_int64_or_nativeint_array custom_ops ~elements
     (mode : Lambda.alloc_mode) dbg =
   let header =

backend/cmm_helpers.mli

@@ -958,6 +958,11 @@ val atomic_compare_and_set :
 
 val emit_gc_roots_table : symbols:symbol list -> phrase list -> phrase list
 
+(** Allocate a block to hold an unboxed float32 array for the given number of
+    elements. *)
+val allocate_unboxed_float32_array :
+  elements:Cmm.expression list -> Lambda.alloc_mode -> Debuginfo.t -> expression
+
 (** Allocate a block to hold an unboxed int32 array for the given number of
     elements. *)
 val allocate_unboxed_int32_array :
@@ -973,13 +978,20 @@ val allocate_unboxed_int64_array :
 val allocate_unboxed_nativeint_array :
   elements:Cmm.expression list -> Lambda.alloc_mode -> Debuginfo.t -> expression
 
+(** Compute the length of an unboxed float32 array. *)
+val unboxed_float32_array_length : expression -> Debuginfo.t -> expression
+
 (** Compute the length of an unboxed int32 array. *)
 val unboxed_int32_array_length : expression -> Debuginfo.t -> expression
 
 (** Compute the length of an unboxed int64 or unboxed nativeint array. *)
 val unboxed_int64_or_nativeint_array_length :
   expression -> Debuginfo.t -> expression
 
+(** Read from an unboxed float32 array (without bounds check). *)
+val unboxed_float32_array_ref :
+  expression -> expression -> Debuginfo.t -> expression
+
 (** Read from an unboxed int32 array (without bounds check). *)
 val unboxed_int32_array_ref :
   expression -> expression -> Debuginfo.t -> expression
@@ -989,6 +1001,14 @@ val unboxed_int32_array_ref :
 val unboxed_int64_or_nativeint_array_ref :
   expression -> expression -> Debuginfo.t -> expression
 
+(** Update an unboxed float32 array (without bounds check). *)
+val unboxed_float32_array_set :
+  expression ->
+  index:expression ->
+  new_value:expression ->
+  Debuginfo.t ->
+  expression
+
 (** Update an unboxed int32 array (without bounds check). *)
 val unboxed_int32_array_set :
   expression ->

middle_end/flambda2/from_lambda/closure_conversion_aux.ml

@@ -507,9 +507,9 @@ module Acc = struct
       | Set_of_closures _ | Boxed_float _ | Boxed_float32 _ | Boxed_int32 _
       | Boxed_int64 _ | Boxed_vec128 _ | Boxed_nativeint _
       | Immutable_float_block _ | Immutable_float_array _
-      | Immutable_value_array _ | Empty_array _ | Immutable_int32_array _
-      | Immutable_int64_array _ | Immutable_nativeint_array _ | Mutable_string _
-      | Immutable_string _ ->
+      | Immutable_float32_array _ | Immutable_value_array _ | Empty_array _
+      | Immutable_int32_array _ | Immutable_int64_array _
+      | Immutable_nativeint_array _ | Mutable_string _ | Immutable_string _ ->
         Value_unknown
     in
     let symbol_approximations =

middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml

@@ -129,9 +129,7 @@ let convert_array_kind (kind : L.array_kind) : converted_array_kind =
   | Paddrarray -> Array_kind Values
   | Pintarray -> Array_kind Immediates
   | Pfloatarray | Punboxedfloatarray Pfloat64 -> Array_kind Naked_floats
-  | Punboxedfloatarray Pfloat32 ->
-    (* CR mslater: (float32) unboxed arrays *)
-    assert false
+  | Punboxedfloatarray Pfloat32 -> Array_kind Naked_float32s
   | Punboxedintarray Pint32 -> Array_kind Naked_int32s
   | Punboxedintarray Pint64 -> Array_kind Naked_int64s
   | Punboxedintarray Pnativeint -> Array_kind Naked_nativeints
@@ -142,12 +140,12 @@ let convert_array_kind_for_length kind : P.Array_kind_for_length.t =
   | Float_array_opt_dynamic -> Float_array_opt_dynamic
 
 module Array_ref_kind = struct
-  (* CR mslater: (float32) unboxed arrays *)
   type t =
     | Immediates
     | Values
     | Naked_floats_to_be_boxed of L.alloc_mode
     | Naked_floats
+    | Naked_float32s
     | Naked_int32s
     | Naked_int64s
     | Naked_nativeints
@@ -173,9 +171,7 @@ let convert_array_ref_kind (kind : L.array_ref_kind) : converted_array_ref_kind
   | Pintarray_ref -> Array_ref_kind Immediates
   | Pfloatarray_ref mode -> Array_ref_kind (Naked_floats_to_be_boxed mode)
   | Punboxedfloatarray_ref Pfloat64 -> Array_ref_kind Naked_floats
-  | Punboxedfloatarray_ref Pfloat32 ->
-    (* CR mslater: (float32) unboxed arrays *)
-    assert false
+  | Punboxedfloatarray_ref Pfloat32 -> Array_ref_kind Naked_float32s
   | Punboxedintarray_ref Pint32 -> Array_ref_kind Naked_int32s
   | Punboxedintarray_ref Pint64 -> Array_ref_kind Naked_int64s
   | Punboxedintarray_ref Pnativeint -> Array_ref_kind Naked_nativeints
@@ -188,6 +184,7 @@ let convert_array_ref_kind_for_length array_ref_kind : P.Array_kind_for_length.t
   | Array_ref_kind Immediates -> Array_kind Immediates
   | Array_ref_kind (Naked_floats | Naked_floats_to_be_boxed _) ->
     Array_kind Naked_floats
+  | Array_ref_kind Naked_float32s -> Array_kind Naked_float32s
   | Array_ref_kind Naked_int32s -> Array_kind Naked_int32s
   | Array_ref_kind Naked_int64s -> Array_kind Naked_int64s
   | Array_ref_kind Naked_nativeints -> Array_kind Naked_nativeints
@@ -198,6 +195,7 @@ module Array_set_kind = struct
     | Values of P.Init_or_assign.t
     | Naked_floats
     | Naked_floats_to_be_unboxed
+    | Naked_float32s
     | Naked_int32s
     | Naked_int64s
     | Naked_nativeints
@@ -213,6 +211,7 @@ let convert_intermediate_array_set_kind (kind : Array_set_kind.t) :
   | Immediates -> Immediates
   | Values init_or_assign -> Values init_or_assign
   | Naked_floats | Naked_floats_to_be_unboxed -> Naked_floats
+  | Naked_float32s -> Naked_float32s
   | Naked_int32s -> Naked_int32s
   | Naked_int64s -> Naked_int64s
   | Naked_nativeints -> Naked_nativeints
@@ -231,9 +230,7 @@ let convert_array_set_kind (kind : L.array_set_kind) : converted_array_set_kind
   | Pintarray_set -> Array_set_kind Immediates
   | Pfloatarray_set -> Array_set_kind Naked_floats_to_be_unboxed
   | Punboxedfloatarray_set Pfloat64 -> Array_set_kind Naked_floats
-  | Punboxedfloatarray_set Pfloat32 ->
-    (* CR mslater: (float32) unboxed arrays *)
-    assert false
+  | Punboxedfloatarray_set Pfloat32 -> Array_set_kind Naked_float32s
   | Punboxedintarray_set Pint32 -> Array_set_kind Naked_int32s
   | Punboxedintarray_set Pint64 -> Array_set_kind Naked_int64s
   | Punboxedintarray_set Pnativeint -> Array_set_kind Naked_nativeints
@@ -246,6 +243,7 @@ let convert_array_set_kind_for_length array_set_kind : P.Array_kind_for_length.t
   | Array_set_kind Immediates -> Array_kind Immediates
   | Array_set_kind (Naked_floats | Naked_floats_to_be_unboxed) ->
     Array_kind Naked_floats
+  | Array_set_kind Naked_float32s -> Array_kind Naked_float32s
   | Array_set_kind Naked_int32s -> Array_kind Naked_int32s
   | Array_set_kind Naked_int64s -> Array_kind Naked_int64s
   | Array_set_kind Naked_nativeints -> Array_kind Naked_nativeints
@@ -265,8 +263,7 @@ let convert_array_kind_to_duplicate_array_kind (kind : L.array_kind) :
   | Pfloatarray | Punboxedfloatarray Pfloat64 ->
     Duplicate_array_kind (Naked_floats { length = None })
   | Punboxedfloatarray Pfloat32 ->
-    (* CR mslater: (float32) unboxed arrays *)
-    assert false
+    Duplicate_array_kind (Naked_float32s { length = None })
   | Punboxedintarray Pint32 ->
     Duplicate_array_kind (Naked_int32s { length = None })
   | Punboxedintarray Pint64 ->
@@ -596,7 +593,7 @@ let array_vector_access_validity_condition array ~size_int
   let width_in_scalars =
     match array_kind with
     | Naked_floats | Immediates | Naked_int64s | Naked_nativeints -> 2
-    | Naked_int32s -> 4
+    | Naked_int32s | Naked_float32s -> 4
     | Values ->
       Misc.fatal_error
         "Attempted to load/store a SIMD vector from/to a value array."
@@ -820,6 +817,8 @@ let array_load_unsafe ~array ~index (array_ref_kind : Array_ref_kind.t)
       ~current_region
   | Naked_floats ->
     Binary (Array_load (Naked_floats, Scalar, Mutable), array, index)
+  | Naked_float32s ->
+    Binary (Array_load (Naked_float32s, Scalar, Mutable), array, index)
   | Naked_int32s ->
     Binary (Array_load (Naked_int32s, Scalar, Mutable), array, index)
   | Naked_int64s ->
@@ -831,8 +830,8 @@ let array_set_unsafe ~array ~index ~new_value
     (array_set_kind : Array_set_kind.t) : H.expr_primitive =
   let new_value =
     match array_set_kind with
-    | Immediates | Values _ | Naked_floats | Naked_int32s | Naked_int64s
-    | Naked_nativeints ->
+    | Immediates | Values _ | Naked_floats | Naked_float32s | Naked_int32s
+    | Naked_int64s | Naked_nativeints ->
       new_value
     | Naked_floats_to_be_unboxed -> unbox_float new_value
   in