Implement structured constants

Author: ncik-roberts

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
 
@@ -3886,6 +3891,8 @@ let cfloat32 f = Cmm.Csingle f
 
 let cfloat f = Cmm.Cdouble f
 
+let cint32 f = Cmm.Cint32 f
+
 let cvec128 bits = Cmm.Cvec128 bits
 
 let symbol_address s = Cmm.Csymbol_address s

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 *)
@@ -874,6 +878,9 @@ val infix_field_address : dbg:Debuginfo.t -> expression -> int -> expression
 (** Static integer. *)
 val cint : nativeint -> data_item
 
+(** Static int32. *)
+val cint32 : nativeint -> data_item
+
 (** Static float32. *)
 val cfloat32 : float -> data_item
 

middle_end/flambda2/from_lambda/closure_conversion.ml

@@ -52,11 +52,7 @@ type close_functions_result =
 
 type declare_const_result =
   | Field of Field_of_static_block.t
-  | Unboxed_float of Numeric_types.Float_by_bit_pattern.t
-  | Unboxed_float32 of Numeric_types.Float32_by_bit_pattern.t
-  | Unboxed_int32 of Numeric_types.Int32.t
-  | Unboxed_int64 of Numeric_types.Int64.t
-  | Unboxed_nativeint of Targetint_32_64.t
+  | Unboxed_number of Field_of_static_block.Mixed_field.Unboxed_number.t
 
 let manufacture_symbol acc proposed_name =
   let acc, linkage_name =
@@ -113,10 +109,10 @@ let rec declare_const acc (const : Lambda.structured_constant) :
     acc, Field (Tagged_immediate (Targetint_31_63.of_char c)), "char"
   | Const_base (Const_unboxed_float c) ->
     let c = Numeric_types.Float_by_bit_pattern.of_string c in
-    acc, Unboxed_float c, "unboxed_float"
+    acc, Unboxed_number (Unboxed_float c), "unboxed_float"
   | Const_base (Const_unboxed_float32 c) ->
     let c = Numeric_types.Float32_by_bit_pattern.of_string c in
-    acc, Unboxed_float32 c, "unboxed_float32"
+    acc, Unboxed_number (Unboxed_float32 c), "unboxed_float32"
   | Const_base (Const_string (s, _, _)) ->
     register_const acc (SC.immutable_string s) "immstring"
   | Const_base (Const_float c) ->
@@ -133,12 +129,14 @@ let rec declare_const acc (const : Lambda.structured_constant) :
     (* CR pchambart: this should be pushed further to lambda *)
     let c = Targetint_32_64.of_int64 (Int64.of_nativeint c) in
     register_const acc (SC.boxed_nativeint (Const c)) "nativeint"
-  | Const_base (Const_unboxed_int32 c) -> acc, Unboxed_int32 c, "unboxed_int32"
-  | Const_base (Const_unboxed_int64 c) -> acc, Unboxed_int64 c, "unboxed_int64"
+  | Const_base (Const_unboxed_int32 c) ->
+    acc, Unboxed_number (Unboxed_int32 c), "unboxed_int32"
+  | Const_base (Const_unboxed_int64 c) ->
+    acc, Unboxed_number (Unboxed_int64 c), "unboxed_int64"
   | Const_base (Const_unboxed_nativeint c) ->
     (* CR pchambart: this should be pushed further to lambda *)
     let c = Targetint_32_64.of_int64 (Int64.of_nativeint c) in
-    acc, Unboxed_nativeint c, "unboxed_nativeint"
+    acc, Unboxed_number (Unboxed_nativeint c), "unboxed_nativeint"
   | Const_immstring c -> register_const acc (SC.immutable_string c) "immstring"
   | Const_float_block c ->
     register_const acc
@@ -169,8 +167,7 @@ let rec declare_const acc (const : Lambda.structured_constant) :
           let acc, f, _ = declare_const acc c in
           match f with
           | Field f -> acc, f
-          | Unboxed_float _ | Unboxed_float32 _ | Unboxed_int32 _
-          | Unboxed_int64 _ | Unboxed_nativeint _ ->
+          | Unboxed_number _ ->
             Misc.fatal_errorf
               "Unboxed constants are not allowed inside of Const_block: %a"
               Printlambda.structured_constant const)
@@ -180,6 +177,23 @@ let rec declare_const acc (const : Lambda.structured_constant) :
       SC.block (Tag.Scannable.create_exn tag) Immutable field_of_blocks
     in
     register_const acc const "const_block"
+  | Const_mixed_block (tag, shape, consts) ->
+    let shape = K.Mixed_block_shape.from_lambda shape in
+    let acc, field_of_blocks =
+      List.fold_left_map
+        (fun acc c : (_ * Field_of_static_block.Mixed_field.t) ->
+          let acc, f, _ = declare_const acc c in
+          match f with
+          | Field f -> acc, Value f
+          | Unboxed_number num -> acc, Unboxed_number num)
+        acc consts
+    in
+    let const : SC.t =
+      SC.mixed_block
+        (Tag.Scannable.create_exn tag)
+        Immutable shape field_of_blocks
+    in
+    register_const acc const "const_mixed_block"
 
 let close_const0 acc (const : Lambda.structured_constant) =
   let acc, const, name = declare_const acc const in
@@ -189,27 +203,27 @@ let close_const0 acc (const : Lambda.structured_constant) =
       Simple.const (Reg_width_const.tagged_immediate i),
       name,
       Flambda_kind.With_subkind.tagged_immediate )
-  | Unboxed_float f ->
+  | Unboxed_number (Unboxed_float f) ->
     ( acc,
       Simple.const (Reg_width_const.naked_float f),
       name,
       Flambda_kind.With_subkind.naked_float )
-  | Unboxed_float32 f ->
+  | Unboxed_number (Unboxed_float32 f) ->
     ( acc,
       Simple.const (Reg_width_const.naked_float32 f),
       name,
       Flambda_kind.With_subkind.naked_float32 )
-  | Unboxed_int32 i ->
+  | Unboxed_number (Unboxed_int32 i) ->
     ( acc,
       Simple.const (Reg_width_const.naked_int32 i),
       name,
       Flambda_kind.With_subkind.naked_int32 )
-  | Unboxed_int64 i ->
+  | Unboxed_number (Unboxed_int64 i) ->
     ( acc,
       Simple.const (Reg_width_const.naked_int64 i),
       name,
       Flambda_kind.With_subkind.naked_int64 )
-  | Unboxed_nativeint i ->
+  | Unboxed_number (Unboxed_nativeint i) ->
     ( acc,
       Simple.const (Reg_width_const.naked_nativeint i),
       name,

middle_end/flambda2/from_lambda/closure_conversion_aux.ml

@@ -485,6 +485,8 @@ module Acc = struct
     let declared_symbols = (symbol, constant) :: t.declared_symbols in
     let approx : _ Value_approximation.t =
       match (constant : Static_const.t) with
+      (* CR layouts v5.9: Support cross-module inlining for mixed blocks. *)
+      | Mixed_block _ -> Value_unknown
       | Block (tag, mut, fields) ->
         if not (Mutability.is_mutable mut)
         then

middle_end/flambda2/parser/flambda_to_fexpr.ml

@@ -698,6 +698,9 @@ let static_const env (sc : Static_const.t) : Fexpr.static_data =
     let tag = tag |> Tag.Scannable.to_int in
     let elements = List.map (field_of_block env) fields in
     Block { tag; mutability; elements }
+  | Mixed_block _ ->
+    Misc.fatal_error
+      "fexpr support for statically-allocated mixed blocks not yet implemented"
   | Set_of_closures _ -> assert false
   | Boxed_float32 f -> Boxed_float32 (or_variable float32 env f)
   | Boxed_float f -> Boxed_float (or_variable float env f)

middle_end/flambda2/simplify/rebuilt_static_const.ml

@@ -103,18 +103,29 @@ let create_set_of_closures are_rebuilding set =
         free_names
       }
 
+let free_names_of_fields fields free_names_of_field =
+  ListLabels.fold_left fields ~init:Name_occurrences.empty
+    ~f:(fun free_names field ->
+      Name_occurrences.union free_names (free_names_of_field field))
+
 let create_block are_rebuilding tag is_mutable ~fields =
   if ART.do_not_rebuild_terms are_rebuilding
   then
     let free_names =
-      ListLabels.fold_left fields ~init:Name_occurrences.empty
-        ~f:(fun free_names field ->
-          Name_occurrences.union free_names
-            (Field_of_static_block.free_names field))
+      free_names_of_fields fields Field_of_static_block.free_names
     in
     Block_not_rebuilt { free_names }
   else create_normal_non_code (SC.block tag is_mutable fields)
 
+let create_mixed_block are_rebuilding tag is_mutable shape ~fields =
+  if ART.do_not_rebuild_terms are_rebuilding
+  then
+    let free_names =
+      free_names_of_fields fields Field_of_static_block.Mixed_field.free_names
+    in
+    Block_not_rebuilt { free_names }
+  else create_normal_non_code (SC.mixed_block tag is_mutable shape fields)
+
 let create_boxed_float32 are_rebuilding or_var =
   if ART.do_not_rebuild_terms are_rebuilding
   then Block_not_rebuilt { free_names = Or_variable.free_names or_var }
@@ -224,8 +235,8 @@ let map_set_of_closures t ~f =
                 (SC.set_of_closures set_of_closures);
             free_names = Set_of_closures.free_names set_of_closures
           }
-      | Block _ | Boxed_float _ | Boxed_float32 _ | Boxed_int32 _
-      | Boxed_int64 _ | Boxed_vec128 _ | Boxed_nativeint _
+      | Block _ | Mixed_block _ | Boxed_float _ | Boxed_float32 _
+      | Boxed_int32 _ | Boxed_int64 _ | Boxed_vec128 _ | Boxed_nativeint _
       | Immutable_float_block _ | Immutable_float_array _
       | Immutable_float32_array _ | Immutable_int32_array _
       | Immutable_int64_array _ | Immutable_nativeint_array _

middle_end/flambda2/simplify/rebuilt_static_const.mli

@@ -47,6 +47,14 @@ val create_block :
   fields:Field_of_static_block.t list ->
   t
 
+val create_mixed_block :
+  Are_rebuilding_terms.t ->
+  Tag.Scannable.t ->
+  Mutability.t ->
+  Flambda_kind.Mixed_block_shape.t ->
+  fields:Field_of_static_block.Mixed_field.t list ->
+  t
+
 val create_boxed_float32 :
   Are_rebuilding_terms.t ->
   Numeric_types.Float32_by_bit_pattern.t Or_variable.t ->

middle_end/flambda2/simplify/simplify_static_const.ml

@@ -41,6 +41,24 @@ let simplify_field_of_block dacc (field : Field_of_static_block.t) =
           (* CR mshinwell: This should be "invalid" and propagate up *)
           field, ty)
 
+let simplify_field_of_mixed_block dacc
+    (field : Field_of_static_block.Mixed_field.t) :
+    Field_of_static_block.Mixed_field.t * _ =
+  match field with
+  | Value value ->
+    let value', ty = simplify_field_of_block dacc value in
+    (if value == value' then field else Value value'), ty
+  | Unboxed_number num ->
+    let ty =
+      match num with
+      | Unboxed_float _ -> T.any_naked_float
+      | Unboxed_float32 _ -> T.any_naked_float32
+      | Unboxed_int32 _ -> T.any_naked_int32
+      | Unboxed_int64 _ -> T.any_naked_int64
+      | Unboxed_nativeint _ -> T.any_naked_nativeint
+    in
+    field, ty
+
 let simplify_or_variable dacc type_for_const (or_variable : _ Or_variable.t)
     kind =
   let denv = DA.denv dacc in
@@ -65,6 +83,19 @@ let rebuild_naked_number_array dacc ~bind_result_sym kind type_creator creator
   in
   creator (DA.are_rebuilding_terms dacc) fields, dacc
 
+let simplify_static_const_block_type ~tag ~fields ~shape
+    ~(is_mutable : Mutability.t) =
+  (* Same as Simplify_variadic_primitive.simplify_make_block_of_values *)
+  let tag = Tag.Scannable.to_tag tag in
+  match is_mutable with
+  | Immutable ->
+    T.immutable_block ~is_unique:false tag ~shape ~fields
+      Alloc_mode.For_types.heap
+  | Immutable_unique ->
+    T.immutable_block ~is_unique:true tag ~shape ~fields
+      Alloc_mode.For_types.heap
+  | Mutable -> T.any_value
+
 let simplify_static_const_of_kind_value dacc (static_const : Static_const.t)
     ~result_sym : Rebuilt_static_const.t * DA.t =
   let bind_result_sym typ =
@@ -79,23 +110,28 @@ let simplify_static_const_of_kind_value dacc (static_const : Static_const.t)
     in
     let fields, field_tys = List.split fields_with_tys in
     let ty =
-      (* Same as Simplify_variadic_primitive.simplify_make_block_of_values *)
-      let tag = Tag.Scannable.to_tag tag in
-      let fields = field_tys in
-      match is_mutable with
-      | Immutable ->
-        T.immutable_block ~is_unique:false tag ~shape:K.Block_shape.Value_only
-          ~fields Alloc_mode.For_types.heap
-      | Immutable_unique ->
-        T.immutable_block ~is_unique:true tag ~shape:K.Block_shape.Value_only
-          ~fields Alloc_mode.For_types.heap
-      | Mutable -> T.any_value
+      simplify_static_const_block_type ~tag ~fields:field_tys ~shape:Value_only
+        ~is_mutable
     in
     let dacc = bind_result_sym ty in
     ( Rebuilt_static_const.create_block
         (DA.are_rebuilding_terms dacc)
         tag is_mutable ~fields,
       dacc )
+  | Mixed_block (tag, is_mutable, shape, fields) ->
+    let fields_with_tys =
+      List.map (fun field -> simplify_field_of_mixed_block dacc field) fields
+    in
+    let fields, field_tys = List.split fields_with_tys in
+    let ty =
+      simplify_static_const_block_type ~tag ~fields:field_tys
+        ~shape:(Mixed_record shape) ~is_mutable
+    in
+    let dacc = bind_result_sym ty in
+    ( Rebuilt_static_const.create_mixed_block
+        (DA.are_rebuilding_terms dacc)
+        tag is_mutable shape ~fields,
+      dacc )
   | Boxed_float32 or_var ->
     let or_var, ty =
       simplify_or_variable dacc