Limit the number of parameters for an uncurried or untupled function (#9620)

This commit introduces a quantity Lambda.max_arity that is the maximal
number of parameters that a Lambda function can have.

Uncurrying is throttled so that, for example, assuming the limit is 10,
a 15-argument curried function fun x1 ... x15 -> e
becomes a 10-argument function (x1...x10) that returns a 5-argument
function (x11...x15).

Concerning untupling, a function that takes a N-tuple of arguments,
where N is above the limit, remains a function that takes a single
argument that is a tuple.

Currently, max_arity is set to 126 in native-code, to match the new
representation of closures implemented by #9619.  A signed 8-bit field
is used to store the arity.  126 instead of 127 to account for the
extra "environment" argument.

In bytecode the limit is infinity (max_int) because there are no needs
yet for a limit on the number of parameters.

.depend

@@ -3270,6 +3270,7 @@ lambda/lambda.cmo : \
     typing/ident.cmi \
     typing/env.cmi \
     lambda/debuginfo.cmi \
+    utils/clflags.cmi \
     parsing/asttypes.cmi \
     lambda/lambda.cmi
 lambda/lambda.cmx : \
@@ -3281,6 +3282,7 @@ lambda/lambda.cmx : \
     typing/ident.cmx \
     typing/env.cmx \
     lambda/debuginfo.cmx \
+    utils/clflags.cmx \
     parsing/asttypes.cmi \
     lambda/lambda.cmi
 lambda/lambda.cmi : \

Changes

@@ -42,6 +42,11 @@ Working version
 - #9441: Add RISC-V RV64G native-code backend.
   (Nicolás Ojeda Bär, review by Xavier Leroy and Gabriel Scherer)
 
+- #9620: Limit the number of parameters for an uncurried or untupled
+   function.  Functions with more parameters than that are left
+   partially curried or tupled.
+   (Xavier Leroy, review by Mark Shinwell)
+
 ### Standard library:
 
 * #9554: add primitive __FUNCTION__ that returns the name of the current method

lambda/lambda.ml

@@ -893,5 +893,10 @@ let function_is_curried func =
   | Curried -> true
   | Tupled -> false
 
+let max_arity () =
+  if !Clflags.native_code then 126 else max_int
+  (* 126 = 127 (the maximal number of parameters supported in C--)
+           - 1 (the hidden parameter containing the environment) *)
+
 let reset () =
   raise_count := 0

lambda/lambda.mli

@@ -412,6 +412,12 @@ val default_stub_attribute : function_attribute
 
 val function_is_curried : lfunction -> bool
 
+val max_arity : unit -> int
+  (** Maximal number of parameters for a function, or in other words,
+      maximal length of the [params] list of a [lfunction] record.
+      This is unlimited ([max_int]) for bytecode, but limited
+      (currently to 126) for native code. *)
+
 (***********************)
 (* For static failures *)
 (***********************)

lambda/simplif.ml

@@ -515,7 +515,8 @@ let simplify_lets lam =
   | Lfunction{kind; params; return=return1; body = l; attr; loc} ->
       begin match simplif l with
         Lfunction{kind=Curried; params=params'; return=return2; body; attr; loc}
-        when kind = Curried && optimize ->
+        when kind = Curried && optimize &&
+             List.length params + List.length params' <= Lambda.max_arity() ->
           (* The return type is the type of the value returned after
              applying all the parameters to the function. The return
              type of the merged function taking [params @ params'] as

lambda/translclass.ml

@@ -30,7 +30,8 @@ exception Error of Location.t * error
 let lfunction params body =
   if params = [] then body else
   match body with
-  | Lfunction {kind = Curried; params = params'; body = body'; attr; loc} ->
+  | Lfunction {kind = Curried; params = params'; body = body'; attr; loc}
+    when List.length params + List.length params' <= Lambda.max_arity() ->
       Lfunction {kind = Curried; params = params @ params';
                  return = Pgenval;
                  body = body'; attr;

lambda/translcore.ml

@@ -724,22 +724,24 @@ and transl_apply ~scopes ?(should_be_tailcall=false) ?(inlined = Default_inline)
      : Lambda.lambda)
 
 and transl_function0
-      ~scopes loc return untuplify_fn repr partial (param:Ident.t) cases =
+      ~scopes loc return untuplify_fn max_arity
+      repr partial (param:Ident.t) cases =
   match cases with
     [{c_lhs=pat; c_guard=None;
       c_rhs={exp_desc = Texp_function { arg_label = _; param = param'; cases;
         partial = partial'; }; exp_env; exp_type} as exp}]
-    when Parmatch.inactive ~partial pat ->
+    when max_arity > 1 && Parmatch.inactive ~partial pat ->
       let kind = value_kind pat.pat_env pat.pat_type in
       let return_kind = function_return_value_kind exp_env exp_type in
       let ((_, params, return), body) =
-        transl_function0 ~scopes exp.exp_loc return_kind false
+        transl_function0 ~scopes exp.exp_loc return_kind false (max_arity - 1)
           repr partial' param' cases
       in
       ((Curried, (param, kind) :: params, return),
        Matching.for_function ~scopes loc None (Lvar param)
          [pat, body] partial)
-  | {c_lhs={pat_desc = Tpat_tuple pl}} :: _ when untuplify_fn ->
+  | {c_lhs={pat_desc = Tpat_tuple pl}} :: _
+    when untuplify_fn && List.length pl <= max_arity ->
       begin try
         let size = List.length pl in
         let pats_expr_list =
@@ -800,7 +802,8 @@ and transl_function ~scopes e param cases partial =
       (function repr ->
          let pl = push_defaults e.exp_loc [] cases partial in
          let return_kind = function_return_value_kind e.exp_env e.exp_type in
-         transl_function0 ~scopes e.exp_loc return_kind !Clflags.native_code
+         transl_function0 ~scopes e.exp_loc return_kind
+           !Clflags.native_code (Lambda.max_arity())
            repr partial param pl)
   in
   let attr = default_function_attribute in
@@ -1093,7 +1096,8 @@ and transl_letop ~scopes loc env let_ ands param case partial =
       event_function ~scopes case.c_rhs
         (function repr ->
            transl_function0 ~scopes case.c_rhs.exp_loc return_kind
-             !Clflags.native_code repr partial param [case])
+             !Clflags.native_code (Lambda.max_arity())
+             repr partial param [case])
     in
     let attr = default_function_attribute in
     let loc = of_location ~scopes case.c_rhs.exp_loc in