New mechanism to determine arity of externals.

CHANGELOG.md

@@ -20,6 +20,7 @@
 - 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
 - Add regex literals as syntax sugar for `@bs.re`. https://github.com/rescript-lang/rescript-compiler/pull/6776
+- 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/frontend/external_ffi_types.ml

@@ -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/ml/primitive.ml

@@ -20,49 +20,32 @@ 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 =
   {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 +56,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.mli

@@ -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/translcore.ml

@@ -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/typedecl.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/test/ExternalArity.res

@@ -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)