Code review

Author: mshinwell

backend/cmm.mli

@@ -224,6 +224,7 @@ and operation =
   | Copaque (* Sys.opaque_identity *)
   | Cbeginregion | Cendregion
   | Ctuple_field of int * machtype array
+      (* the [machtype array] refers to the whole tuple *)
 
 (* This is information used exclusively during construction of cmm terms by
    cmmgen, and thus irrelevant for selectgen and flambda2. *)

backend/cmm_helpers.ml

@@ -1078,7 +1078,7 @@ module Extended_machtype = struct
       typ_any_int
     | Pvalue Pintval -> typ_tagged_int
     | Pvalue _ -> typ_val
-    | Punboxed_product fields -> Array.concat @@ List.map of_layout fields
+    | Punboxed_product fields -> Array.concat (List.map of_layout fields)
 end
 
 let machtype_of_layout layout =

backend/selectgen.ml

@@ -921,18 +921,20 @@ method emit_expr_aux (env:environment) exp :
          ret (self#insert_op_debug env Iopaque dbg rs rs)
       end
   | Cop(Ctuple_field(field, fields_layout), [arg], dbg) ->
-    begin match self#emit_expr env arg with
+      begin match self#emit_expr env arg with
         None -> None
       | Some loc_exp ->
-        let flat_size a = Array.fold_left (fun acc t -> acc + Array.length t) 0 a in
+        let flat_size a =
+          Array.fold_left (fun acc t -> acc + Array.length t) 0 a
+        in
         assert(Array.length loc_exp = flat_size fields_layout);
         let before = Array.sub fields_layout 0 field in
         let size_before = flat_size before in
         let field_slice =
           Array.sub loc_exp size_before (Array.length fields_layout.(field))
         in
         ret field_slice
-    end
+      end
   | Cop(op, args, dbg) ->
       begin match self#emit_parts_list env args with
         None -> None

middle_end/.ocamlformat-enable

@@ -1,2 +1,4 @@
+clambda_layout.ml
+clambda_layout.mli
 mangling.ml
 mangling.mli

middle_end/clambda_layout.ml

@@ -1,27 +1,43 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                        Pierre Chambart, OCamlPro                       *)
+(*                                                                        *)
+(*   Copyright 2023 OCamlPro SAS                                          *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
 type atom =
   | Value
   | Value_int
   | Unboxed_float
   | Unboxed_int of Lambda.boxed_integer
 
-let rec fold_left_layout (f : 'acc -> 'e -> atom -> 'acc)
-    (acc : 'acc) (expr : Clambda.ulambda) (layout : Clambda_primitives.layout) : 'acc =
+let rec fold_left_layout (f : 'acc -> 'e -> atom -> 'acc) (acc : 'acc)
+    (expr : Clambda.ulambda) (layout : Clambda_primitives.layout) : 'acc =
   match layout with
-  | Ptop ->
-    Misc.fatal_error "[Ptop] can't be stored in a closure."
+  | Ptop -> Misc.fatal_error "[Ptop] can't be stored in a closure."
   | Pbottom ->
     Misc.fatal_error
-      "[Pbottom] should have been eliminated as dead code \
-       and not stored in a closure."
+      "[Pbottom] should have been eliminated as dead code and not stored in a \
+       closure."
   | Punboxed_float -> f acc expr Unboxed_float
   | Punboxed_int bi -> f acc expr (Unboxed_int bi)
   | Pvalue Pintval -> f acc expr Value_int
   | Pvalue _ -> f acc expr Value
   | Punboxed_product layouts ->
-    List.fold_left (fun acc (field, layout) ->
+    List.fold_left
+      (fun acc (field, layout) ->
         let expr : Clambda.ulambda =
-          Uprim (Punboxed_product_field (field, layouts), [expr], Debuginfo.none) in
-        fold_left_layout f acc expr layout) acc
+          Uprim (Punboxed_product_field (field, layouts), [expr], Debuginfo.none)
+        in
+        fold_left_layout f acc expr layout)
+      acc
       (List.mapi (fun i v -> i, v) layouts)
 
 type ('visible, 'invisible) decomposition' =
@@ -30,10 +46,12 @@ type ('visible, 'invisible) decomposition' =
   | Product of ('visible, 'invisible) decomposition' array
 
 type decomposition =
-  | Atom of { offset : int; layout : atom }
+  | Atom of
+      { offset : int;
+        layout : atom
+      }
   | Product of decomposition array
 
-
 let print_atom ppf = function
   | Value -> Format.fprintf ppf "val"
   | Value_int -> Format.fprintf ppf "int"
@@ -42,7 +60,8 @@ let print_atom ppf = function
   | Unboxed_int Pint64 -> Format.fprintf ppf "unboxed_int64"
   | Unboxed_int Pnativeint -> Format.fprintf ppf "unboxed_nativeint"
 
-let equal_decomposition = (=)
+let equal_decomposition = ( = )
+
 let rec print_decomposition ppf dec =
   match dec with
   | Atom { offset; layout } ->
@@ -54,30 +73,26 @@ let rec print_decomposition ppf dec =
 
 let rec decompose (layout : Lambda.layout) : _ decomposition' =
   match layout with
-  | Ptop ->
-    Misc.fatal_error "[Ptop] can't be stored in a closure."
+  | Ptop -> Misc.fatal_error "[Ptop] can't be stored in a closure."
   | Pbottom ->
     Misc.fatal_error
-      "[Pbottom] should have been eliminated as dead code \
-       and not stored in a closure."
+      "[Pbottom] should have been eliminated as dead code and not stored in a \
+       closure."
   | Punboxed_float -> Gc_invisible ((), Unboxed_float)
   | Punboxed_int bi -> Gc_invisible ((), Unboxed_int bi)
   | Pvalue Pintval -> Gc_invisible ((), Value_int)
   | Pvalue _ -> Gc_visible ((), Value)
-  | Punboxed_product l ->
-    Product (Array.of_list (List.map decompose l))
+  | Punboxed_product l -> Product (Array.of_list (List.map decompose l))
 
 let rec solidify (dec : (int, int) decomposition') : decomposition =
   match dec with
   | Gc_visible (offset, layout) -> Atom { offset; layout }
   | Gc_invisible (offset, layout) -> Atom { offset; layout }
-  | Product a ->
-    Product (Array.map solidify a)
+  | Product a -> Product (Array.map solidify a)
 
-let rec fold_decompose
-    (f1 : 'acc -> 'a -> atom -> 'acc * 'b) (f2 : 'acc -> 'c -> atom -> 'acc * 'd)
-    (acc : 'acc) (d : ('a, 'c) decomposition') :
-  'acc * ('b, 'd) decomposition' =
+let rec fold_decompose (f1 : 'acc -> 'a -> atom -> 'acc * 'b)
+    (f2 : 'acc -> 'c -> atom -> 'acc * 'd) (acc : 'acc)
+    (d : ('a, 'c) decomposition') : 'acc * ('b, 'd) decomposition' =
   match d with
   | Gc_visible (v, layout) ->
     let acc, v = f1 acc v layout in
@@ -90,36 +105,22 @@ let rec fold_decompose
     acc, Product elts
 
 let atom_size (layout : atom) =
-  match layout with
-  | Value
-  | Value_int
-  | Unboxed_float
-  | Unboxed_int _ -> 1
+  match layout with Value | Value_int | Unboxed_float | Unboxed_int _ -> 1
 
 let assign_invisible_offsets init_pos (var, dec) =
-  let f_visible acc () _layout =
-    acc, ()
-  in
-  let f_invisible acc () layout =
-    acc + atom_size layout, acc
-  in
+  let f_visible acc () _layout = acc, () in
+  let f_invisible acc () layout = acc + atom_size layout, acc in
   let acc, dec = fold_decompose f_visible f_invisible init_pos dec in
   acc, (var, dec)
 
 let assign_visible_offsets init_pos (var, dec) =
-  let f_visible acc () layout =
-    acc + atom_size layout, acc
-  in
-  let f_invisible acc off _layout =
-    acc, off
-  in
+  let f_visible acc () layout = acc + atom_size layout, acc in
+  let f_invisible acc off _layout = acc, off in
   let acc, dec = fold_decompose f_visible f_invisible init_pos dec in
   acc, (var, solidify dec)
 
 let decompose_free_vars ~base_offset ~free_vars =
-  let free_vars =
-    List.map (fun (var, kind) -> var, decompose kind) free_vars
-  in
+  let free_vars = List.map (fun (var, kind) -> var, decompose kind) free_vars in
   let base_offset, free_vars =
     List.fold_left_map assign_invisible_offsets base_offset free_vars
   in

middle_end/clambda_layout.mli

@@ -1,15 +1,35 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                        Pierre Chambart, OCamlPro                       *)
+(*                                                                        *)
+(*   Copyright 2023 OCamlPro SAS                                          *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
 type atom =
   | Value
   | Value_int
   | Unboxed_float
   | Unboxed_int of Lambda.boxed_integer
 
 val fold_left_layout :
-  ('acc -> Clambda.ulambda -> atom -> 'acc) -> 'acc -> Clambda.ulambda ->
-  Clambda_primitives.layout -> 'acc
+  ('acc -> Clambda.ulambda -> atom -> 'acc) ->
+  'acc ->
+  Clambda.ulambda ->
+  Clambda_primitives.layout ->
+  'acc
 
 type decomposition =
-  | Atom of { offset : int; layout : atom }
+  | Atom of
+      { offset : int;
+        layout : atom
+      }
   | Product of decomposition array
 
 val equal_decomposition : decomposition -> decomposition -> bool

middle_end/flambda2/from_lambda/closure_conversion.ml

@@ -2098,8 +2098,9 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply)
         ~params ~params_arity ~removed_params:Ident.Set.empty
         ~return:apply.return_arity ~return_continuation ~exn_continuation
         ~my_region:apply.region ~body:fbody ~attr ~loc:apply.loc
-        ~free_idents_of_body ~closure_alloc_mode ~num_trailing_local_params
-        ~contains_no_escaping_local_allocs Recursive.Non_recursive ]
+        ~free_idents_of_body ~closure_alloc_mode
+        ~num_trailing_complex_local_params ~contains_no_escaping_local_allocs
+        Recursive.Non_recursive ]
   in
   let body acc env =
     let arg = find_simple_from_id env wrapper_id in

middle_end/flambda2/from_lambda/lambda_to_flambda.ml

@@ -1230,7 +1230,10 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation)
       ~body:(fun acc env ccenv after_defining_expr ->
         cps_tail acc env ccenv defining_expr after_defining_expr k_exn)
       ~handler:(fun acc env ccenv ->
-        let kind = Flambda_kind.With_subkind.unsafe_from_lambda value_kind in
+        let kind =
+          Flambda_kind.With_subkind.from_lambda_values_and_unboxed_numbers_only
+            value_kind
+        in
         let env, new_id = Env.register_mutable_variable env id kind in
         let body acc ccenv = cps acc env ccenv body k k_exn in
         CC.close_let acc ccenv
@@ -1285,7 +1288,10 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation)
             | Ptop | Pbottom ->
               Misc.fatal_error "Cannot bind layout [Ptop] or [Pbottom]"
             | Pvalue _ | Punboxed_int _ | Punboxed_float ->
-              env, [id, Flambda_kind.With_subkind.unsafe_from_lambda layout]
+              ( env,
+                [ ( id,
+                    Flambda_kind.With_subkind
+                    .from_lambda_values_and_unboxed_numbers_only layout ) ] )
             | Punboxed_product layouts ->
               let arity_component =
                 Flambda_arity.Component_for_creation.Unboxed_product