flambda-backend: Syntactic function arity typechecking and translation (#1817)

* Newtypes

* Constraint/coercion

* Add map_half_typed_cases

* Implement type-checking/translation

This also promotes tests whose output changes.

* Add upstream tests

Tests from:
  - ocaml/ocaml#12236 (and the corresponding updates to outputs found in ocaml/ocaml#12386 and ocaml/ocaml#12391)
  - ocaml/ocaml#12496 (not merged)

* Fix ocamldoc

* Update chamelon minimizer

* Respond to requested changes to minimizer

* update new test brought in from rebase

* Fix bug in chunking code

* `make bootstrap`

* Add Ast_invariant check

* Fix type-directed disambiguation of optional arg defaults

* Minor comments from review

* Run syntactic-arity test, update output, and fix printing bug

* Remove unnecessary call to escape

* Backport changes from upstream to comparative alloc tests

* Avoid the confusing [Split_function_ty] module

* Comment [split_function_ty] better.

* [contains_gadt] as variant instead of bool

* Calculate is_final_val_param on the fly rather than precomputing indexes

* Note suboptimality

* Get typecore typechecking

* Finish resolving merge conflicts and run tests

* make bootstrap

* Add iteration on / mapping over locations and attributes

* Reduce diff and fix typo in comment:

* promote change to zero-alloc arg structure

* Undo unintentional formatting changes to chamelon

* Fix minimizer

* Minimize diff

* Fix bug with local-returning method

* Fix regression where polymorphic parameters weren't allowed to be used in same parameter list as GADTs

* Fix merge conflicts and make bootstrap

* Apply expected diff to zero-alloc test changed in this PR

Author: ncik-roberts

boot/ocamlc

@@ -547,7 +547,9 @@ type loop_attribute =
   | Never_loop (* [@loop never] *)
   | Default_loop (* no [@loop] attribute *)
 
-type function_kind = Curried of {nlocal: int} | Tupled
+type curried_function_kind = { nlocal : int } [@@unboxed]
+
+type function_kind = Curried of curried_function_kind | Tupled
 
 type let_kind = Strict | Alias | StrictOpt
 
@@ -575,6 +577,7 @@ type function_attribute = {
   is_opaque: bool;
   stub: bool;
   tmc_candidate: bool;
+  may_fuse_arity: bool;
 }
 
 type scoped_location = Debuginfo.Scoped_location.t
@@ -768,6 +771,14 @@ let default_function_attribute = {
   is_opaque = false;
   stub = false;
   tmc_candidate = false;
+  (* Plain functions ([fun] and [function]) set [may_fuse_arity] to [false] so
+     that runtime arity matches syntactic arity in more situations.
+     Many things compile to functions without having a notion of syntactic arity
+     that survives typechecking, e.g. functors. Multi-arg functors are compiled
+     as nested unary functions, and rely on the arity fusion in simplif to make
+     them multi-argument. So, we keep arity fusion turned on by default for now.
+  *)
+  may_fuse_arity = true;
 }
 
 let default_stub_attribute =

boot/ocamllex

@@ -436,10 +436,12 @@ type loop_attribute =
   | Never_loop (* [@loop never] *)
   | Default_loop (* no [@loop] attribute *)
 
-type function_kind = Curried of {nlocal: int} | Tupled
+type curried_function_kind = { nlocal: int } [@@unboxed]
 (* [nlocal] determines how many arguments may be partially applied
-   before the resulting closure must be locally allocated.
-   See [lfunction] for details *)
+    before the resulting closure must be locally allocated.
+    See [lfunction] for details *)
+
+type function_kind = Curried of curried_function_kind | Tupled
 
 type let_kind = Strict | Alias | StrictOpt
 (* Meaning of kinds for let x = e in e':
@@ -471,6 +473,9 @@ type function_attribute = {
   is_opaque: bool;
   stub: bool;
   tmc_candidate: bool;
+  (* [may_fuse_arity] is true if [simplif.ml] is permitted to fuse arity, i.e.,
+     to perform the rewrite [fun x -> fun y -> e] to [fun x y -> e] *)
+  may_fuse_arity: bool;
 }
 
 type parameter_attribute = No_attributes

lambda/.ocamlformat-enable

@@ -2950,6 +2950,18 @@ let split_extension_cases tag_lambda_list =
        | _, Ordinary _ -> assert false)
     tag_lambda_list
 
+let transl_match_on_option value_kind arg loc ~if_some ~if_none =
+  (* This case is very frequent, it corresponds to
+      options and lists. *)
+  (* Keeping the Pisint test would make the bytecode
+      slightly worse, but it lets the native compiler generate
+      better code -- see #10681. *)
+  if !Clflags.native_code then
+    Lifthenelse(Lprim (Pisint { variant_only = true }, [ arg ], loc),
+                if_none, if_some, value_kind)
+  else
+    Lifthenelse(arg, if_some, if_none, value_kind)
+
 let combine_constructor value_kind loc arg pat_env cstr partial ctx def
     (descr_lambda_list, total1, pats) =
   match cstr.cstr_tag with
@@ -3042,16 +3054,8 @@ let combine_constructor value_kind loc arg pat_env cstr partial ctx def
             with
             | 1, 1, [ (0, act1) ], [ (0, act2) ]
               when not (Clflags.is_flambda2 ()) ->
-                (* This case is very frequent, it corresponds to
-                   options and lists. *)
-                (* Keeping the Pisint test would make the bytecode
-                   slightly worse, but it lets the native compiler generate
-                   better code -- see #10681. *)
-                if !Clflags.native_code then
-                  Lifthenelse(Lprim (Pisint { variant_only = true }, [ arg ], loc),
-                              act1, act2, value_kind)
-                else
-                  Lifthenelse(arg, act2, act1, value_kind)
+                transl_match_on_option value_kind arg loc
+                  ~if_none:act1 ~if_some:act2
             | n, 0, _, [] ->
                 (* The matched type defines constant constructors only.
                    (typically the constant cases are dense, so
@@ -4109,6 +4113,33 @@ let for_multiple_match ~scopes ~return_layout loc paraml mode pat_act_list parti
     (do_for_multiple_match ~scopes ~return_layout loc paraml mode pat_act_list
        partial)
 
+let for_optional_arg_default
+    ~scopes loc pat ~param ~default_arg ~default_arg_sort ~return_layout body
+  : lambda
+  =
+  (* CR layouts v1.5: It's sad to compute [default_arg_layout] here as we
+     immediately go and do it again in [for_let]. We should rework [for_let]
+     so it can take a precomputed layout.
+  *)
+  let default_arg_layout =
+    Typeopt.layout pat.pat_env pat.pat_loc default_arg_sort pat.pat_type
+  in
+  let supplied_or_default =
+    transl_match_on_option
+      default_arg_layout
+      (Lvar param)
+      Loc_unknown
+      ~if_none:default_arg
+      ~if_some:
+        (Lprim
+           (* CR ncik-roberts: Check whether we need something better here. *)
+           (Pfield (0, Pointer, Reads_agree),
+            [ Lvar param ],
+            Loc_unknown))
+  in
+  for_let ~scopes ~arg_sort:default_arg_sort ~return_layout
+    loc supplied_or_default pat body
+
 (* Error report *)
 (* CR layouts v5: This file didn't use to have the report_error infrastructure -
    I added it only for the void sanity checking in this module, which I'm not

lambda/lambda.ml

@@ -45,6 +45,21 @@ val for_tupled_function:
         Ident.t list -> (pattern list * lambda) list -> partial ->
         lambda
 
+(** [for_optional_arg_default pat body ~default_arg ~param] is:
+    {[
+      let $pat =
+        match $param with
+        | Some x -> x
+        | None -> $default_arg
+      in
+      $body
+    ]}
+*)
+val for_optional_arg_default:
+  scopes:scopes -> Location.t -> pattern -> param:Ident.t ->
+  default_arg:lambda -> default_arg_sort:Jkind.sort ->
+  return_layout:layout -> lambda -> lambda
+
 exception Cannot_flatten
 
 val flatten_pattern: int -> pattern -> pattern list

lambda/lambda.mli

@@ -555,13 +555,14 @@ let simplify_lets lam =
       | _ -> no_opt ()
       end
   | Lfunction{kind=outer_kind; params; return=outer_return; body = l;
-              attr; loc; ret_mode; mode; region=outer_region} ->
+              attr=attr1; loc; ret_mode; mode; region=outer_region} ->
       begin match outer_kind, outer_region, simplif l with
         Curried {nlocal=0},
         true,
         Lfunction{kind=Curried _ as kind; params=params'; return=return2;
-                  body; attr; loc; mode=inner_mode; ret_mode; region}
+                  body; attr=attr2; loc; mode=inner_mode; ret_mode; region}
         when optimize &&
+             attr1.may_fuse_arity && attr2.may_fuse_arity &&
              List.length params + List.length params' <= Lambda.max_arity() ->
           (* The returned function's mode should match the outer return mode *)
           assert (is_heap_mode inner_mode);
@@ -570,9 +571,9 @@ let simplify_lets lam =
              type of the merged function taking [params @ params'] as
              parameters is the type returned after applying [params']. *)
           let return = return2 in
-          lfunction ~kind ~params:(params @ params') ~return ~body ~attr ~loc ~mode ~ret_mode ~region
+          lfunction ~kind ~params:(params @ params') ~return ~body ~attr:attr1 ~loc ~mode ~ret_mode ~region
       | kind, region, body ->
-          lfunction ~kind ~params ~return:outer_return ~body ~attr ~loc ~mode ~ret_mode ~region
+          lfunction ~kind ~params ~return:outer_return ~body ~attr:attr1 ~loc ~mode ~ret_mode ~region
       end
   | Llet(_str, _k, v, Lvar w, l2) when optimize ->
       Hashtbl.add subst v (simplif (Lvar w));

lambda/matching.ml

@@ -1006,9 +1006,9 @@ and traverse_binding outer_ctx inner_ctx (var, def) =
       match lfun.mode, lfun.kind with
       | Alloc_heap, Tupled ->
          (* Support of Tupled function: see [choice_apply]. *)
-         Curried {nlocal=0}
+          Curried {nlocal=0}
       | Alloc_local, (Tupled | Curried _) ->
-         Curried {nlocal=List.length params}
+          Curried {nlocal=List.length params}
       | Alloc_heap, (Curried _ as k) ->
          (* Prepending arguments does not affect nlocal *)
          k