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

@@ -1600,7 +1600,8 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot decl
   let code =
     Code.create code_id ~params_and_body
       ~free_names_of_params_and_body:(Acc.free_names acc) ~params_arity
-      ~num_trailing_local_params:(Function_decl.num_trailing_local_params decl)
+      ~num_trailing_complex_local_params:
+        (Function_decl.num_trailing_complex_local_params decl)
       ~result_arity:(Flambda_arity.unarize_t return)
       ~result_types:Unknown
       ~contains_no_escaping_local_allocs:
@@ -1701,7 +1702,7 @@ let close_functions acc external_env ~current_region function_declarations =
     List.fold_left
       (fun approx_map decl ->
         (* The only fields of metadata which are used for this pass are
-           params_arity, is_tupled, num_trailing_local_params,
+           params_arity, is_tupled, num_trailing_complex_local_params,
            contains_no_escaping_local_allocs, and result_arity. We try to
            populate the different fields as much as possible, but put dummy
            values when they are not yet computed or simply too expensive to
@@ -1729,8 +1730,8 @@ let close_functions acc external_env ~current_region function_declarations =
         in
         let metadata =
           Code_metadata.create code_id ~params_arity
-            ~num_trailing_local_params:
-              (Function_decl.num_trailing_local_params decl)
+            ~num_trailing_complex_local_params:
+              (Function_decl.num_trailing_complex_local_params decl)
             ~result_arity:(Flambda_arity.unarize_t result_arity)
             ~result_types:Unknown
             ~contains_no_escaping_local_allocs:
@@ -2015,7 +2016,7 @@ let close_let_rec acc env ~function_declarations
 
 let wrap_partial_application acc env apply_continuation (apply : IR.apply)
     approx ~provided ~provided_arity ~missing_arity ~arity
-    ~num_trailing_local_params ~contains_no_escaping_local_allocs =
+    ~num_trailing_complex_local_params ~contains_no_escaping_local_allocs =
   (* In case of partial application, creates a wrapping function from scratch to
      allow inlining and lifting *)
   let wrapper_id = Ident.create_local ("partial_" ^ Ident.name apply.func) in
@@ -2077,17 +2078,20 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply)
       (Ident.Set.singleton apply.func)
       all_args
   in
-  let closure_alloc_mode, num_trailing_local_params =
-    let num_leading_heap_params =
+  let closure_alloc_mode, num_trailing_complex_local_params =
+    let num_leading_complex_heap_params =
       (* This is a pre-unarization calculation so uses [num_params] not
          [cardinal_unarized]. *)
-      Flambda_arity.num_params arity - num_trailing_local_params
+      Flambda_arity.num_params arity - num_trailing_complex_local_params
     in
-    if num_provided <= num_leading_heap_params
-    then Lambda.alloc_heap, num_trailing_local_params
+    if num_provided <= num_leading_complex_heap_params
+    then Lambda.alloc_heap, num_trailing_complex_local_params
     else
-      let num_supplied_local_args = num_provided - num_leading_heap_params in
-      Lambda.alloc_local, num_trailing_local_params - num_supplied_local_args
+      let num_supplied_local_args =
+        num_provided - num_leading_complex_heap_params
+      in
+      ( Lambda.alloc_local,
+        num_trailing_complex_local_params - num_supplied_local_args )
   in
   if not (Lambda.sub_mode closure_alloc_mode apply.IR.mode)
   then
@@ -2096,12 +2100,13 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply)
       (Debuginfo.Scoped_location.string_of_scoped_location apply.IR.loc);
   let function_declarations =
     [ Function_decl.create ~let_rec_ident:(Some wrapper_id) ~function_slot
-        ~kind:(Lambda.Curried { nlocal = num_trailing_local_params })
+        ~kind:(Lambda.Curried { nlocal = num_trailing_complex_local_params })
         ~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
@@ -2239,7 +2244,7 @@ let close_apply acc env (apply : IR.apply) : Expr_with_acc.t =
       Some
         ( Code_metadata.params_arity metadata,
           Code_metadata.is_tupled metadata,
-          Code_metadata.num_trailing_local_params metadata,
+          Code_metadata.num_trailing_complex_local_params metadata,
           Code_metadata.contains_no_escaping_local_allocs metadata )
     | Value_unknown -> None
     | Value_symbol _ | Value_int _ | Block_approximation _ ->
@@ -2256,7 +2261,7 @@ let close_apply acc env (apply : IR.apply) : Expr_with_acc.t =
   | Some
       ( arity,
         is_tupled,
-        num_trailing_local_params,
+        num_trailing_complex_local_params,
         contains_no_escaping_local_allocs ) -> (
     let acc, _ = find_simples_and_arity acc env apply.args in
     let split_args =
@@ -2327,7 +2332,7 @@ let close_apply acc env (apply : IR.apply) : Expr_with_acc.t =
                inlined_attribute_on_partial_application_msg Inlined))
       | Never_inlined | Hint_inlined | Default_inlined -> ());
       wrap_partial_application acc env apply.continuation apply approx ~provided
-        ~provided_arity ~missing_arity ~arity ~num_trailing_local_params
+        ~provided_arity ~missing_arity ~arity ~num_trailing_complex_local_params
         ~contains_no_escaping_local_allocs
     | Over_app { full; provided_arity; remaining; remaining_arity } ->
       let full_args_call apply_continuation ~region acc =

middle_end/flambda2/from_lambda/closure_conversion_aux.ml

@@ -690,15 +690,15 @@ module Function_decls = struct
         loc : Lambda.scoped_location;
         recursive : Recursive.t;
         closure_alloc_mode : Lambda.alloc_mode;
-        num_trailing_local_params : int;
+        num_trailing_complex_local_params : int;
         contains_no_escaping_local_allocs : bool
       }
 
     let create ~let_rec_ident ~function_slot ~kind ~params ~params_arity
         ~removed_params ~return ~return_continuation ~exn_continuation
         ~my_region ~body ~(attr : Lambda.function_attribute) ~loc
         ~free_idents_of_body recursive ~closure_alloc_mode
-        ~num_trailing_local_params ~contains_no_escaping_local_allocs =
+        ~num_trailing_complex_local_params ~contains_no_escaping_local_allocs =
       let let_rec_ident =
         match let_rec_ident with
         | None -> Ident.create_local "unnamed_function"
@@ -720,7 +720,7 @@ module Function_decls = struct
         loc;
         recursive;
         closure_alloc_mode;
-        num_trailing_local_params;
+        num_trailing_complex_local_params;
         contains_no_escaping_local_allocs
       }
 
@@ -766,7 +766,8 @@ module Function_decls = struct
 
     let closure_alloc_mode t = t.closure_alloc_mode
 
-    let num_trailing_local_params t = t.num_trailing_local_params
+    let num_trailing_complex_local_params t =
+      t.num_trailing_complex_local_params
 
     let contains_no_escaping_local_allocs t =
       t.contains_no_escaping_local_allocs