New mechanism to determine arity of externals.

The arity of external declarations is currently determined just based on the untyped parse tree.
This is probably because the "real" arity is ambiguous in curried mode, and the convention is that an explicit type of the form `t1 => t2 => t3` determines arity 2, but type aliases are ignored.

Here's an example:
https://rescript-lang.org/try?version=v11.1.2&code=C4TwDgpgBArlC8UAUBLAdsANFdwCUCAfDhgFAACAbgIYA2UEAHsBAE5p1SUCMAXLAigAiSkKgB6cVGqsUoKADNWAewC2AlAGccqsLRQBjORRr0mLdp0oAmfqgzZcBeMVyCRYydNnytDRnqGxqS0EMCK3IKMRFzcSIyYjHghYYrWUTE28YnJQA

In the example

```res
type u = (int, int) => int
@Val external v1: u = "v" // arity from u is implicit
@Val external v2: (int, int) => int = "v" // arity is explicit

let f1 = x => v1(x,x)
let f2 = x => v2(x,x)
```

we have that `v2` is determined to have arity 2, but the arity of `v1` is not determined.
As a consequence, the code generated for `f1` uses runtime `Curry`, both in curried an uncurried mode.

This PR uses the actual type coming from the type checker when in uncurried mode, as that does not suffer from ambiguity.

The consequences are that the external behaves the same however the type is defined, and in the example, no `Curry` runtime is generated.

Author: cristianoc

CHANGELOG.md

@@ -19,6 +19,7 @@
 - Throws an instance of JavaScript's `new Error()` and adds the extension payload for `cause` option. https://github.com/rescript-lang/rescript-compiler/pull/6611
 - Allow free vars in types for type coercion `e :> t`. https://github.com/rescript-lang/rescript-compiler/pull/6828
 - Allow `private` in with constraints. https://github.com/rescript-lang/rescript-compiler/pull/6843
+- Improved mechanism to determine arity of externals, which is consistent however the type is written. https://github.com/rescript-lang/rescript-compiler/pull/6874
 
 #### :boom: Breaking Change
 

jscomp/build_tests/react_ppx/src/gpr_3695_test.bs.js

@@ -240,14 +240,7 @@ let from_string s : t =
 
 let () =
   Primitive.coerce :=
-    fun ({
-           prim_name;
-           prim_arity;
-           prim_native_name;
-           prim_alloc = _;
-           prim_native_repr_args = _;
-           prim_native_repr_res = _;
-         } :
+    fun ({prim_name; prim_arity; prim_native_name; prim_alloc = _} :
           Primitive.description) (p2 : Primitive.description) ->
       let p2_native = p2.prim_native_name in
       prim_name = p2.prim_name && prim_arity = p2.prim_arity

jscomp/frontend/external_ffi_types.ml

@@ -20,49 +20,33 @@ open Parsetree
 
 type boxed_integer = Pbigint | Pint32 | Pint64
 
-type native_repr =
-  | Same_as_ocaml_repr
-
 type description =
   { prim_name: string;         (* Name of primitive  or C function *)
     prim_arity: int;           (* Number of arguments *)
     prim_alloc: bool;          (* Does it allocates or raise? *)
     prim_native_name: string;  (* Name of C function for the nat. code gen. *)
-    prim_native_repr_args: native_repr list;
-    prim_native_repr_res: native_repr }
+  }
 
 let coerce : (description -> description -> bool) ref = 
   ref (fun 
         (p1 : description) (p2 : description) ->
         p1 = p2
       )
 
-
-
-let rec make_native_repr_args arity x =
-  if arity = 0 then
-    []
-  else
-    x :: make_native_repr_args (arity - 1) x
-
 let simple ~name ~arity ~alloc =
+  (* Printf.eprintf "XXX simple name:%s arity:%d\n" name arity; *)
   {prim_name = name;
    prim_arity = arity;
    prim_alloc = alloc;
-   prim_native_name = "";
-   prim_native_repr_args = make_native_repr_args arity Same_as_ocaml_repr;
-   prim_native_repr_res = Same_as_ocaml_repr}
+   prim_native_name = "";}
 
-let make ~name ~alloc ~native_name ~native_repr_args ~native_repr_res =
+let make ~name ~alloc ~native_name ~arity =
   {prim_name = name;
-   prim_arity = List.length native_repr_args;
+   prim_arity = arity;
    prim_alloc = alloc;
-   prim_native_name = native_name;
-   prim_native_repr_args = native_repr_args;
-   prim_native_repr_res = native_repr_res}
+   prim_native_name = native_name;}
 
-let parse_declaration valdecl ~native_repr_args ~native_repr_res =
-  let arity = List.length native_repr_args in
+let parse_declaration valdecl ~arity =
   let name, native_name =
     match valdecl.pval_prim with
     | name :: name2 :: _ -> (name, name2)
@@ -73,9 +57,7 @@ let parse_declaration valdecl ~native_repr_args ~native_repr_res =
   {prim_name = name;
    prim_arity = arity;
    prim_alloc = true;
-   prim_native_name = native_name;
-   prim_native_repr_args = native_repr_args;
-   prim_native_repr_res = native_repr_res}
+   prim_native_name = native_name;}
 
 open Outcometree
 

jscomp/ml/primitive.ml

@@ -17,18 +17,12 @@
 
 type boxed_integer = Pbigint | Pint32 | Pint64
 
-(* Representation of arguments/result for the native code version
-   of a primitive *)
-type native_repr =
-  | Same_as_ocaml_repr
-
 type description = private
   { prim_name: string;         (* Name of primitive  or C function *)
     prim_arity: int;           (* Number of arguments *)
     prim_alloc: bool;          (* Does it allocates or raise? *)
     prim_native_name: string;  (* Name of C function for the nat. code gen. *)
-    prim_native_repr_args: native_repr list;
-    prim_native_repr_res: native_repr }
+  }
 
 (* Invariant [List.length d.prim_native_repr_args = d.prim_arity] *)
 
@@ -42,14 +36,12 @@ val make
   :  name:string
   -> alloc:bool
   -> native_name:string
-  -> native_repr_args: native_repr list
-  -> native_repr_res: native_repr
+  -> arity: int
   -> description
 
 val parse_declaration
   :  Parsetree.value_description
-  -> native_repr_args:native_repr list
-  -> native_repr_res:native_repr
+  -> arity: int
   -> description
 
 val print

jscomp/ml/primitive.mli

@@ -851,9 +851,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda =
       )
       | _ -> "#fn_mk" in
       let prim =
-        Primitive.make ~name ~alloc:true ~native_name:arity_s
-          ~native_repr_args:[ Same_as_ocaml_repr ]
-          ~native_repr_res:Same_as_ocaml_repr
+        Primitive.make ~name ~alloc:true ~native_name:arity_s ~arity:1
       in
       Lprim
         ( Pccall prim
@@ -1188,8 +1186,7 @@ and transl_record loc env fields repres opt_init_expr =
         let arity_s = String.sub lbl_name 1 (String.length lbl_name - 1) in
         let prim =
           Primitive.make ~name:"#fn_mk" ~alloc:true ~native_name:arity_s
-            ~native_repr_args:[ Same_as_ocaml_repr ]
-            ~native_repr_res:Same_as_ocaml_repr
+            ~arity:1
         in
         Lprim
           ( Pccall prim

jscomp/ml/translcore.ml

@@ -1707,28 +1707,19 @@ let transl_exception env sext =
 
 
 
-let rec parse_native_repr_attributes env core_type ty =
+let rec arity_from_arrow_type env core_type ty =
   match core_type.ptyp_desc, (Ctype.repr ty).desc
   with
   | Ptyp_arrow (_, _, ct2), Tarrow (_, _, t2, _) ->
-    let repr_arg = Same_as_ocaml_repr  in
-    let repr_args, repr_res =
-      parse_native_repr_attributes env ct2 t2 
-    in
-    (repr_arg :: repr_args, repr_res)
+    1 + (arity_from_arrow_type env ct2 t2)
   | Ptyp_arrow _, _ | _, Tarrow _ -> assert false
-  | _ -> ([], Same_as_ocaml_repr)
+  | _ -> 0
 
 
-let parse_native_repr_attributes env core_type ty =
-  match core_type.ptyp_desc, (Ctype.repr ty).desc
-  with
-  | Ptyp_constr ({txt = Lident "function$"}, [{ptyp_desc = Ptyp_arrow (_, _, ct2)}; _]),
-    Tconstr (Pident {name = "function$"},[{desc = Tarrow (_, _, t2, _)}; _],_) ->
-    let repr_args, repr_res = parse_native_repr_attributes env ct2 t2 in
-    let native_repr_args = Same_as_ocaml_repr :: repr_args in
-    (native_repr_args, repr_res)
-  | _ -> parse_native_repr_attributes env core_type ty
+let parse_arity env core_type ty =
+  match Ast_uncurried.uncurried_type_get_arity_opt ~env ty with
+  | Some arity -> arity
+  | None -> arity_from_arrow_type env core_type ty
 
 (* Translate a value declaration *)
 let transl_value_decl env loc valdecl =
@@ -1742,30 +1733,23 @@ let transl_value_decl env loc valdecl =
   | [] ->
       raise (Error(valdecl.pval_loc, Val_in_structure))
   | _ ->
-      let native_repr_args, native_repr_res =
-          let rec scann (attrs : Parsetree.attributes)  = 
+      let arity =
+          let rec scan_attributes (attrs : Parsetree.attributes)  = 
             match attrs with 
-            | ({txt = "internal.arity";_},
+            | ({txt = "internal.arity";_}, (* This is likely not needed in uncurried mode *)
               PStr [ {pstr_desc = Pstr_eval
                         (
                           ({pexp_desc = Pexp_constant (Pconst_integer (i,_))} :
                              Parsetree.expression) ,_)}]) :: _ ->
                Some (int_of_string i)              
-            | _ :: rest  -> scann rest 
+            | _ :: rest  -> scan_attributes rest 
             | [] -> None 
-          and make n = 
-            if n = 0 then []
-            else Primitive.Same_as_ocaml_repr :: make (n - 1)
           in 
-            match scann valdecl.pval_attributes with 
-            | None ->  parse_native_repr_attributes env valdecl.pval_type ty 
-            | Some x -> make x , Primitive.Same_as_ocaml_repr
-      in
-      let prim =
-        Primitive.parse_declaration valdecl
-          ~native_repr_args
-          ~native_repr_res
+          match scan_attributes valdecl.pval_attributes with 
+          | None ->  parse_arity env valdecl.pval_type ty 
+          | Some x -> x
       in
+      let prim = Primitive.parse_declaration valdecl ~arity in
       let prim_native_name = prim.prim_native_name in 
       if prim.prim_arity = 0 &&
          not ( String.length prim_native_name >= 20 &&

jscomp/ml/typedecl.ml

@@ -0,0 +1,8 @@
+@@uncurried
+
+type u = (int, int) => int
+@val external v1: u = "v" // arity from u is implicit
+@val external v2: (int, int) => int = "v" // arity is explicit
+
+let f1 = x => v1(x,x)
+let f2 = x => v2(x,x)