Refactor make_block

Author: mshinwell

backend/cmm_helpers.ml

@@ -1632,12 +1632,12 @@ 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

backend/cmm_helpers.mli

@@ -309,11 +309,19 @@ 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 =

middle_end/flambda2/to_cmm/to_cmm_primitive.ml

@@ -88,25 +88,27 @@ let check_alloc_fields = function
 let make_block ~dbg kind alloc_mode args =
   check_alloc_fields args;
   let mode = Alloc_mode.For_allocations.to_lambda alloc_mode in
-  match (kind : P.Block_kind.t) with
-  | Values (tag, _) -> C.make_alloc ~mode dbg (Tag.Scannable.to_int tag) args
-  | Naked_floats ->
-    C.make_float_alloc ~mode dbg (Tag.to_int Tag.double_array_tag) args
-  | Mixed (tag, shape) ->
-    let value_prefix_size = K.Mixed_block_shape.value_prefix_size shape in
-    let flat_suffix =
-      Array.map
-        (fun (flat_elt : K.Flat_suffix_element.t) : C.Flat_suffix_element.t ->
-          match flat_elt with
-          | Tagged_immediate -> Tagged_immediate
-          | Naked_float -> Naked_float
-          | Naked_float32 -> Naked_float32
-          | Naked_int32 -> Naked_int32
-          | Naked_int64 | Naked_nativeint -> Naked_int64_or_nativeint)
-        (K.Mixed_block_shape.flat_suffix shape)
-    in
-    C.make_mixed_alloc ~mode dbg ~tag:(Tag.Scannable.to_int tag)
-      ~value_prefix_size ~flat_suffix args
+  let allocator, tag =
+    match (kind : P.Block_kind.t) with
+    | Values (tag, _) -> C.make_alloc, Tag.Scannable.to_tag tag
+    | Naked_floats -> C.make_float_alloc, Tag.double_array_tag
+    | Mixed (tag, shape) ->
+      let value_prefix_size = K.Mixed_block_shape.value_prefix_size shape in
+      let flat_suffix =
+        Array.map
+          (fun (flat_elt : K.Flat_suffix_element.t) : C.Flat_suffix_element.t ->
+            match flat_elt with
+            | Tagged_immediate -> Tagged_immediate
+            | Naked_float -> Naked_float
+            | Naked_float32 -> Naked_float32
+            | Naked_int32 -> Naked_int32
+            | Naked_int64 | Naked_nativeint -> Naked_int64_or_nativeint)
+          (K.Mixed_block_shape.flat_suffix shape)
+      in
+      ( C.make_mixed_alloc ~value_prefix_size ~flat_suffix,
+        Tag.Scannable.to_tag tag )
+  in
+  allocator ~mode dbg ~tag:(Tag.to_int tag) args
 
 let block_load ~dbg (kind : P.Block_access_kind.t) (mutability : Mutability.t)
     ~block ~index =
@@ -159,9 +161,9 @@ let make_array ~dbg kind alloc_mode args =
   check_alloc_fields args;
   let mode = Alloc_mode.For_allocations.to_lambda alloc_mode in
   match (kind : P.Array_kind.t) with
-  | Immediates | Values -> C.make_alloc ~mode dbg 0 args
+  | Immediates | Values -> C.make_alloc ~mode dbg ~tag:0 args
   | Naked_floats ->
-    C.make_float_alloc ~mode dbg (Tag.to_int Tag.double_array_tag) args
+    C.make_float_alloc ~mode dbg ~tag:(Tag.to_int Tag.double_array_tag) args
   | Naked_float32s -> C.allocate_unboxed_float32_array ~elements:args mode dbg
   | Naked_int32s -> C.allocate_unboxed_int32_array ~elements:args mode dbg
   | Naked_int64s -> C.allocate_unboxed_int64_array ~elements:args mode dbg

middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml

@@ -615,7 +615,7 @@ let let_dynamic_set_of_closures0 env res ~body ~bound_vars set
     let tag = Tag.(to_int closure_tag) in
     C.make_alloc
       ~mode:(Alloc_mode.For_allocations.to_lambda closure_alloc_mode)
-      dbg tag l
+      dbg ~tag l
   in
   let soc_var = Variable.create "*set_of_closures*" in
   let defining_expr = Env.simple csoc free_vars in