Static allocation for mixed blocks etc.

backend/cmm_helpers.ml

@@ -152,6 +152,11 @@ let block_header ?(scannable_prefix = Scan_all) tag sz =
    structured constants and static module definitions. *)
 let black_block_header tag sz = Nativeint.logor (block_header tag sz) caml_black
 
+let black_mixed_block_header tag sz ~scannable_prefix_len =
+  Nativeint.logor
+    (block_header tag sz ~scannable_prefix:(Scan_prefix scannable_prefix_len))
+    caml_black
+
 let local_block_header ?scannable_prefix tag sz =
   Nativeint.logor (block_header ?scannable_prefix tag sz) caml_local
 
@@ -1106,11 +1111,20 @@ let addr_array_ref arr ofs dbg =
 let int_array_ref arr ofs dbg =
   Cop (mk_load_mut Word_int, [array_indexing log2_size_addr arr ofs dbg], dbg)
 
-let unboxed_float_array_ref arr ofs dbg =
+let unboxed_mutable_float_array_ref arr ofs dbg =
   Cop (mk_load_mut Double, [array_indexing log2_size_float arr ofs dbg], dbg)
 
+let unboxed_immutable_float_array_ref arr ofs dbg =
+  Cop (mk_load_immut Double, [array_indexing log2_size_float arr ofs dbg], dbg)
+
+let unboxed_float_array_ref (mutability : Asttypes.mutable_flag) ~block:arr
+    ~index:ofs dbg =
+  match mutability with
+  | Immutable -> unboxed_immutable_float_array_ref arr ofs dbg
+  | Mutable -> unboxed_mutable_float_array_ref arr ofs dbg
+
 let float_array_ref mode arr ofs dbg =
-  box_float dbg mode (unboxed_float_array_ref arr ofs dbg)
+  box_float dbg mode (unboxed_mutable_float_array_ref arr ofs dbg)
 
 let addr_array_set_heap arr ofs newval dbg =
   Cop
@@ -1618,43 +1632,53 @@ let addr_array_init arr ofs newval dbg =
       [array_indexing log2_size_addr arr ofs dbg; newval],
       dbg )
 
-let make_alloc ~mode dbg tag args =
+let make_alloc ~mode dbg ~tag args =
   make_alloc_generic ~mode
     (fun _ arr ofs newval dbg -> addr_array_init arr ofs newval dbg)
     dbg tag (List.length args) args
 
-let make_float_alloc ~mode dbg tag args =
+let make_float_alloc ~mode dbg ~tag args =
   make_alloc_generic ~mode
     (fun _ -> float_array_set)
     dbg tag
     (List.length args * size_float / size_addr)
     args
 
-let make_mixed_alloc ~mode dbg tag shape args =
-  let ({ value_prefix_len; flat_suffix } : Lambda.mixed_block_shape) = shape in
+module Flat_suffix_element = struct
+  type t =
+    | Tagged_immediate
+    | Naked_float
+    | Naked_float32
+    | Naked_int32
+    | Naked_int64_or_nativeint
+end
+
+let make_mixed_alloc ~mode dbg ~tag ~value_prefix_size
+    ~(flat_suffix : Flat_suffix_element.t array) args =
   (* args with shape [Float] must already have been unboxed. *)
   let set_fn idx arr ofs newval dbg =
-    if idx < value_prefix_len
+    if idx < value_prefix_size
     then addr_array_init arr ofs newval dbg
     else
-      match flat_suffix.(idx - value_prefix_len) with
-      | Imm -> int_array_set arr ofs newval dbg
-      | Float_boxed | 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
+      match flat_suffix.(idx - value_prefix_size) with
+      | Tagged_immediate -> int_array_set arr ofs newval dbg
+      | Naked_float -> float_array_set arr ofs newval dbg
+      | Naked_float32 -> setfield_unboxed_float32 arr ofs newval dbg
+      | Naked_int32 -> setfield_unboxed_int32 arr ofs newval dbg
+      | Naked_int64_or_nativeint ->
+        setfield_unboxed_int64_or_nativeint arr ofs newval dbg
   in
   let size =
     (* CR layouts 5.1: When we pack int32s/float32s more efficiently, this code
        will need to change. *)
-    value_prefix_len + Array.length flat_suffix
+    value_prefix_size + Array.length flat_suffix
   in
   if size_float <> size_addr
   then
     Misc.fatal_error
       "Unable to compile mixed blocks on a platform where a float is not the \
        same width as a value.";
-  make_alloc_generic ~scannable_prefix:(Scan_prefix value_prefix_len) ~mode
+  make_alloc_generic ~scannable_prefix:(Scan_prefix value_prefix_size) ~mode
     set_fn dbg tag size args
 
 (* Record application and currying functions *)
@@ -4124,7 +4148,7 @@ let dls_get ~dbg = Cop (Cdls_get, [], dbg)
 
 let perform ~dbg eff =
   let cont =
-    make_alloc dbg Runtimetags.cont_tag
+    make_alloc dbg ~tag:Runtimetags.cont_tag
       [int_const dbg 0]
       ~mode:Lambda.alloc_heap
   in

backend/cmm_helpers.mli

@@ -37,6 +37,10 @@ val block_header : int -> int -> nativeint
 (** Same as block_header, but with GC bits set to black *)
 val black_block_header : int -> int -> nativeint
 
+(** Same as black_block_header, but for a mixed block *)
+val black_mixed_block_header :
+  int -> int -> scannable_prefix_len:int -> nativeint
+
 val black_closure_header : int -> nativeint
 
 (** Infix header at the given offset *)
@@ -216,7 +220,11 @@ val addr_array_ref : expression -> expression -> Debuginfo.t -> expression
 val int_array_ref : expression -> expression -> Debuginfo.t -> expression
 
 val unboxed_float_array_ref :
-  expression -> expression -> Debuginfo.t -> expression
+  Asttypes.mutable_flag ->
+  block:expression ->
+  index:expression ->
+  Debuginfo.t ->
+  expression
 
 val float_array_ref :
   Lambda.alloc_mode -> expression -> expression -> Debuginfo.t -> expression
@@ -303,19 +311,37 @@ end
 
 (** Allocate a block of regular values with the given tag *)
 val make_alloc :
-  mode:Lambda.alloc_mode -> Debuginfo.t -> int -> expression list -> expression
+  mode:Lambda.alloc_mode ->
+  Debuginfo.t ->
+  tag:int ->
+  expression list ->
+  expression
 
 (** Allocate a block of unboxed floats with the given tag *)
 val make_float_alloc :
-  mode:Lambda.alloc_mode -> Debuginfo.t -> int -> expression list -> expression
+  mode:Lambda.alloc_mode ->
+  Debuginfo.t ->
+  tag:int ->
+  expression list ->
+  expression
+
+module Flat_suffix_element : sig
+  type t =
+    | Tagged_immediate
+    | Naked_float
+    | Naked_float32
+    | Naked_int32
+    | Naked_int64_or_nativeint
+end
 
 (** Allocate an mixed block of the corresponding tag and shape. Initial values
     of the flat suffix should be provided unboxed. *)
 val make_mixed_alloc :
   mode:Lambda.alloc_mode ->
   Debuginfo.t ->
-  int ->
-  Lambda.mixed_block_shape ->
+  tag:int ->
+  value_prefix_size:int ->
+  flat_suffix:Flat_suffix_element.t array ->
   expression list ->
   expression
 

middle_end/flambda2/classic_mode_types/value_approximation.ml

@@ -19,7 +19,7 @@
 type 'code t =
   | Value_unknown
   | Value_symbol of Symbol.t
-  | Value_int of Targetint_31_63.t
+  | Value_const of Reg_width_const.t
   | Closure_approximation of
       { code_id : Code_id.t;
         function_slot : Function_slot.t;
@@ -29,15 +29,18 @@ type 'code t =
         symbol : Symbol.t option
       }
   | Block_approximation of
-      Tag.Scannable.t * 'code t array * Alloc_mode.For_types.t
+      Tag.Scannable.t
+      * Flambda_kind.Scannable_block_shape.t
+      * 'code t array
+      * Alloc_mode.For_types.t
 
 let rec print fmt = function
   | Value_unknown -> Format.fprintf fmt "?"
   | Value_symbol sym -> Symbol.print fmt sym
-  | Value_int i -> Targetint_31_63.print fmt i
+  | Value_const i -> Reg_width_const.print fmt i
   | Closure_approximation { code_id; _ } ->
     Format.fprintf fmt "[%a]" Code_id.print code_id
-  | Block_approximation (tag, fields, _) ->
+  | Block_approximation (tag, _shape, fields, _) ->
     let len = Array.length fields in
     if len < 1
     then Format.fprintf fmt "{}"
@@ -51,15 +54,15 @@ let rec print fmt = function
 
 let is_unknown = function
   | Value_unknown -> true
-  | Value_symbol _ | Value_int _ | Closure_approximation _
+  | Value_symbol _ | Value_const _ | Closure_approximation _
   | Block_approximation _ ->
     false
 
 let rec free_names ~code_free_names approx =
   match approx with
-  | Value_unknown | Value_int _ -> Name_occurrences.empty
+  | Value_unknown | Value_const _ -> Name_occurrences.empty
   | Value_symbol sym -> Name_occurrences.singleton_symbol sym Name_mode.normal
-  | Block_approximation (_tag, approxs, _) ->
+  | Block_approximation (_tag, _shape, approxs, _) ->
     Array.fold_left
       (fun names approx ->
         Name_occurrences.union names (free_names ~code_free_names approx))

middle_end/flambda2/classic_mode_types/value_approximation.mli

@@ -19,7 +19,7 @@
 type 'code t =
   | Value_unknown
   | Value_symbol of Symbol.t
-  | Value_int of Targetint_31_63.t
+  | Value_const of Reg_width_const.t
   | Closure_approximation of
       { code_id : Code_id.t;
         function_slot : Function_slot.t;
@@ -29,7 +29,10 @@ type 'code t =
         symbol : Symbol.t option
       }
   | Block_approximation of
-      Tag.Scannable.t * 'code t array * Alloc_mode.For_types.t
+      Tag.Scannable.t
+      * Flambda_kind.Scannable_block_shape.t
+      * 'code t array
+      * Alloc_mode.For_types.t
 
 val print : Format.formatter -> 'a t -> unit
 

middle_end/flambda2/compare/compare.ml

@@ -285,10 +285,10 @@ let subst_rec_info_expr _env ri =
      symbols and other global names *)
   ri
 
-let subst_field env (field : Field_of_static_block.t) =
-  match field with
-  | Symbol symbol -> Field_of_static_block.Symbol (subst_symbol env symbol)
-  | Tagged_immediate _ | Dynamically_computed _ -> field
+let subst_field env field =
+  Simple.With_debuginfo.create
+    (subst_simple env (Simple.With_debuginfo.simple field))
+    (Simple.With_debuginfo.dbg field)
 
 let subst_call_kind env (call_kind : Call_kind.t) : Call_kind.t =
   match call_kind with
@@ -359,9 +359,10 @@ and subst_static_const env (static_const : Static_const_or_code.t) :
     Static_const_or_code.t =
   match static_const with
   | Code code -> Static_const_or_code.create_code (subst_code env code)
-  | Static_const (Block (tag, mut, fields)) ->
+  | Static_const (Block (tag, mut, shape, fields)) ->
     let fields = List.map (subst_field env) fields in
-    Static_const_or_code.create_static_const (Static_const.block tag mut fields)
+    Static_const_or_code.create_static_const
+      (Static_const.block tag mut shape fields)
   | Static_const (Set_of_closures set_of_closures) ->
     Static_const_or_code.create_static_const
       (Static_const.set_of_closures (subst_set_of_closures env set_of_closures))
@@ -908,14 +909,9 @@ let bound_static env bound_static1 bound_static2 : Bound_static.t Comparison.t =
     (bound_static2 |> Bound_static.to_list)
   |> Comparison.map ~f:Bound_static.create
 
-let fields env (field1 : Field_of_static_block.t)
-    (field2 : Field_of_static_block.t) : Field_of_static_block.t Comparison.t =
-  match field1, field2 with
-  | Symbol symbol1, Symbol symbol2 ->
-    symbols env symbol1 symbol2
-    |> Comparison.map ~f:(fun symbol1' -> Field_of_static_block.Symbol symbol1')
-  | _, _ ->
-    Comparator.of_predicate Field_of_static_block.equal env field1 field2
+let fields env (field1 : Simple.With_debuginfo.t)
+    (field2 : Simple.With_debuginfo.t) : Simple.With_debuginfo.t Comparison.t =
+  Comparator.of_predicate Simple.With_debuginfo.equal env field1 field2
 
 let blocks env block1 block2 =
   triples
@@ -1181,13 +1177,14 @@ and static_consts env (const1 : Static_const_or_code.t)
   match const1, const2 with
   | Code code1, Code code2 ->
     codes env code1 code2 |> Comparison.map ~f:Static_const_or_code.create_code
-  | ( Static_const (Block (tag1, mut1, fields1)),
-      Static_const (Block (tag2, mut2, fields2)) ) ->
+  | ( Static_const (Block (tag1, mut1, shape1, fields1)),
+      Static_const (Block (tag2, mut2, _shape2, fields2)) ) ->
+    (* XXX compare the shapes *)
     blocks env (tag1, mut1, fields1) (tag2, mut2, fields2)
     |> Comparison.map
          ~f:(fun (tag1', mut1', fields1') : Static_const_or_code.t ->
            Static_const_or_code.create_static_const
-             (Static_const.block tag1' mut1' fields1'))
+             (Static_const.block tag1' mut1' shape1 fields1'))
   | Static_const (Set_of_closures set1), Static_const (Set_of_closures set2) ->
     sets_of_closures env set1 set2
     |> Comparison.map ~f:(fun set1' : Static_const_or_code.t ->