Special case uncurried fun with 1 arg of unit type (#6131)

cristianoc · web-flow · commit bbf4fbcaf5ac · 2023-04-12T12:28:44.000+02:00
* Specia case uncurried fun with 1 arg of unit type

* Update artifacts.txt

* v2

* back

* back

* Update artifacts.txt

* simplify

* Seems to work with minimal changes.

* Update artifacts.txt

* Pass the information oneUnitArg lower down the compiler stack.

Instead of removing the arguments on the lambda layer, pass the information down via the lambda layer using the additional field oneUnitArg.

When this reaches the Lam layer with ocaml_fun in Lam_compile, only then remove the param.

This ensures the code emitted is the same, except for the parameter.

* Update CHANGELOG.md
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -12,6 +12,9 @@
 
 # 11.0.0-alpha.2 (Unreleased)
 
+#### :bug: Bug Fix
+- Special case generation of uncurried functions with 1 argument of unit type so they don't take a parameter. https://github.com/rescript-lang/rescript-compiler/pull/6131
+
 ## :rocket: Main New Features
 
 - Add support for type coercion `:>` for records. https://github.com/rescript-lang/rescript-compiler/pull/5721
diff --git a/jscomp/core/js_exp_make.ml b/jscomp/core/js_exp_make.ml
@@ -204,7 +204,8 @@ let unit : t = { expression_desc = Undefined; comment = None }
    [Js_fun_env.empty] is a mutable state ..
 *)
 
-let ocaml_fun ?comment ?immutable_mask ~return_unit ~async params body : t =
+let ocaml_fun ?comment ?immutable_mask ~return_unit ~async ~oneUnitArg params body : t =
+  let params = if oneUnitArg then [] else params in
   let len = List.length params in
   {
     expression_desc =
diff --git a/jscomp/core/js_exp_make.mli b/jscomp/core/js_exp_make.mli
@@ -89,6 +89,7 @@ val ocaml_fun :
   ?immutable_mask:bool array ->
   return_unit:bool ->
   async:bool ->
+  oneUnitArg:bool ->
   J.ident list ->
   J.block ->
   t
diff --git a/jscomp/core/lam.ml b/jscomp/core/lam.ml
@@ -273,7 +273,7 @@ let rec is_eta_conversion_exn params inner_args outer_args : t list =
   | x :: xs, Lvar y :: ys, r :: rest when Ident.same x y ->
       r :: is_eta_conversion_exn xs ys rest
   | ( x :: xs,
-      Lprim ({ primitive = Pjs_fn_make _; args = [ Lvar y ] } as p) :: ys,
+      Lprim ({ primitive = Pjs_fn_make _ | Pjs_fn_make_unit; args = [ Lvar y ] } as p) :: ys,
       r :: rest )
     when Ident.same x y ->
       Lprim { p with args = [ r ] } :: is_eta_conversion_exn xs ys rest
diff --git a/jscomp/core/lam_analysis.ml b/jscomp/core/lam_analysis.ml
@@ -59,7 +59,7 @@ let rec no_side_effects (lam : Lam.t) : bool =
           | _ -> false)
       | Pcreate_extension _ | Pjs_typeof | Pis_null | Pis_not_none | Psome
       | Psome_not_nest | Pis_undefined | Pis_null_undefined | Pnull_to_opt
-      | Pundefined_to_opt | Pnull_undefined_to_opt | Pjs_fn_make _
+      | Pundefined_to_opt | Pnull_undefined_to_opt | Pjs_fn_make _ | Pjs_fn_make_unit
       | Pjs_object_create _
       (* TODO: check *)
       | Pbytes_to_string | Pmakeblock _
diff --git a/jscomp/core/lam_compile.ml b/jscomp/core/lam_compile.ml
@@ -55,7 +55,7 @@ let rec apply_with_arity_aux (fn : J.expression) (arity : int list)
           let params =
             Ext_list.init (x - len) (fun _ -> Ext_ident.create "param")
           in
-          E.ocaml_fun params ~return_unit:false (* unknown info *) ~async:false
+          E.ocaml_fun params ~return_unit:false (* unknown info *) ~async:false ~oneUnitArg:false
             [
               S.return_stmt
                 (E.call
@@ -315,7 +315,7 @@ and compile_external_field_apply (appinfo : Lam.apply) (module_id : Ident.t)
 and compile_recursive_let ~all_bindings (cxt : Lam_compile_context.t)
     (id : Ident.t) (arg : Lam.t) : Js_output.t * initialization =
   match arg with
-  | Lfunction { params; body; attr = { return_unit; async } } ->
+  | Lfunction { params; body; attr = { return_unit; async; oneUnitArg } } ->
       let continue_label = Lam_util.generate_label ~name:id.name () in
       (* TODO: Think about recursive value
          {[
@@ -355,7 +355,7 @@ and compile_recursive_let ~all_bindings (cxt : Lam_compile_context.t)
              it will be renamed into [method]
              when it is detected by a primitive
           *)
-            ~return_unit ~async ~immutable_mask:ret.immutable_mask
+            ~return_unit ~async ~oneUnitArg ~immutable_mask:ret.immutable_mask
             (Ext_list.map params (fun x ->
                  Map_ident.find_default ret.new_params x x))
             [
@@ -366,7 +366,7 @@ and compile_recursive_let ~all_bindings (cxt : Lam_compile_context.t)
             ]
         else
           (* TODO:  save computation of length several times *)
-          E.ocaml_fun params (Js_output.output_as_block output) ~return_unit ~async
+          E.ocaml_fun params (Js_output.output_as_block output) ~return_unit ~async ~oneUnitArg
       in
       ( Js_output.output_of_expression
           (Declare (Alias, id))
@@ -1458,6 +1458,7 @@ and compile_apply (appinfo : Lam.apply) (lambda_cxt : Lam_compile_context.t) =
             *)
           (* TODO: use [fold]*)
           let _, assigned_params, new_params =
+            let args = if ret.params = [] then [] else args in
             Ext_list.fold_left2 ret.params args (0, [], Map_ident.empty)
               (fun param arg (i, assigns, new_params) ->
                 match arg with
@@ -1628,6 +1629,8 @@ and compile_prim (prim_info : Lam.prim_info)
   | { primitive = Pjs_fn_make arity; args = [ fn ]; loc } ->
       compile_lambda lambda_cxt
         (Lam_eta_conversion.unsafe_adjust_to_arity loc ~to_:arity ?from:None fn)
+  | { primitive = Pjs_fn_make_unit; args = [ fn ]; loc } ->
+    compile_lambda lambda_cxt fn
   | { primitive = Pjs_fn_make _; args = [] | _ :: _ :: _ } -> assert false
   | { primitive = Pjs_object_create labels; args } ->
       let args_block, args_expr =
@@ -1666,10 +1669,10 @@ and compile_prim (prim_info : Lam.prim_info)
 and compile_lambda (lambda_cxt : Lam_compile_context.t) (cur_lam : Lam.t) :
     Js_output.t =
   match cur_lam with
-  | Lfunction { params; body; attr = { return_unit; async } } ->
+  | Lfunction { params; body; attr = { return_unit; async; oneUnitArg } } ->
       Js_output.output_of_expression lambda_cxt.continuation
         ~no_effects:no_effects_const
-        (E.ocaml_fun params ~return_unit ~async
+        (E.ocaml_fun params ~return_unit ~async ~oneUnitArg
            (* Invariant:  jmp_table can not across function boundary,
               here we share env
            *)
diff --git a/jscomp/core/lam_compile_primitive.ml b/jscomp/core/lam_compile_primitive.ml
@@ -84,7 +84,7 @@ let translate loc (cxt : Lam_compile_context.t) (prim : Lam_primitive.t)
   | Pis_undefined -> E.is_undef (Ext_list.singleton_exn args)
   | Pis_null_undefined -> E.is_null_undefined (Ext_list.singleton_exn args)
   | Pjs_typeof -> E.typeof (Ext_list.singleton_exn args)
-  | Pjs_unsafe_downgrade _ | Pdebugger | Pvoid_run | Pfull_apply | Pjs_fn_make _
+  | Pjs_unsafe_downgrade _ | Pdebugger | Pvoid_run | Pfull_apply | Pjs_fn_make _ | Pjs_fn_make_unit
     ->
       assert false (* already handled by {!Lam_compile} *)
   | Pjs_fn_method -> assert false
diff --git a/jscomp/core/lam_convert.ml b/jscomp/core/lam_convert.ml
@@ -493,6 +493,8 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) :
           | "#run" -> Pvoid_run
           | "#fn_mk" ->
               Pjs_fn_make (Ext_pervasives.nat_of_string_exn p.prim_native_name)
+          | "#fn_mk_unit" ->
+              Pjs_fn_make_unit
           | "#fn_method" -> Pjs_fn_method
           | "#unsafe_downgrade" ->
               Pjs_unsafe_downgrade { name = Ext_string.empty; setter = false }
diff --git a/jscomp/core/lam_pass_alpha_conversion.ml b/jscomp/core/lam_pass_alpha_conversion.ml
@@ -69,6 +69,12 @@ let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t =
             let arg = simpl arg in
             Lam_eta_conversion.unsafe_adjust_to_arity loc ~to_:len ~from:x arg
         | None -> Lam.prim ~primitive ~args:[ simpl arg ] loc)
+    | Lprim { primitive = Pjs_fn_make_unit; args = [ arg ]; loc } ->
+      let arg = match arg with
+      | Lfunction ({arity=1; params=[x]; attr; body}) ->
+        Lam.function_ ~params:[x] ~attr:{attr with oneUnitArg=true} ~body ~arity:1
+      | _ -> arg in
+      simpl arg
     | Lprim { primitive; args; loc } ->
         Lam.prim ~primitive ~args:(Ext_list.map args simpl) loc
     | Lfunction { arity; params; body; attr } ->
diff --git a/jscomp/core/lam_primitive.ml b/jscomp/core/lam_primitive.ml
@@ -129,6 +129,7 @@ type t =
   | Pupdate_mod
   | Praw_js_code of Js_raw_info.t
   | Pjs_fn_make of int
+  | Pjs_fn_make_unit
   | Pvoid_run
   | Pfull_apply
   (* we wrap it when do the conversion to prevent
@@ -307,6 +308,7 @@ let eq_primitive_approx (lhs : t) (rhs : t) =
       | Pjs_unsafe_downgrade rhs -> name = rhs.name && setter = rhs.setter
       | _ -> false)
   | Pjs_fn_make i -> ( match rhs with Pjs_fn_make i1 -> i = i1 | _ -> false)
+  | Pjs_fn_make_unit -> rhs = Pjs_fn_make_unit
   | Pvoid_run -> rhs = Pvoid_run
   | Pfull_apply -> rhs = Pfull_apply
   | Pjs_fn_method -> rhs = Pjs_fn_method
diff --git a/jscomp/core/lam_primitive.mli b/jscomp/core/lam_primitive.mli
@@ -121,6 +121,7 @@ type t =
   | Pupdate_mod
   | Praw_js_code of Js_raw_info.t
   | Pjs_fn_make of int
+  | Pjs_fn_make_unit
   | Pvoid_run
   | Pfull_apply
   | Pjs_fn_method
diff --git a/jscomp/core/lam_print.ml b/jscomp/core/lam_print.ml
@@ -63,6 +63,7 @@ let primitive ppf (prim : Lam_primitive.t) =
   | Pvoid_run -> fprintf ppf "#run"
   | Pfull_apply -> fprintf ppf "#full_apply"
   | Pjs_fn_make i -> fprintf ppf "js_fn_make_%i" i
+  | Pjs_fn_make_unit -> fprintf ppf "js_fn_make_unit"
   | Pjs_fn_method -> fprintf ppf "js_fn_method"
   | Pdebugger -> fprintf ppf "debugger"
   | Praw_js_code _ -> fprintf ppf "[raw]"
diff --git a/jscomp/ml/lambda.ml b/jscomp/ml/lambda.ml
@@ -270,6 +270,7 @@ type function_attribute = {
   stub: bool;
   return_unit : bool;
   async : bool;
+  oneUnitArg : bool;
 }
 
 type lambda =
@@ -298,7 +299,8 @@ and lfunction =
     params: Ident.t list;
     body: lambda;
     attr: function_attribute; (* specified with [@inline] attribute *)
-    loc: Location.t; }
+    loc: Location.t;
+ }
 
 and lambda_apply =
   { ap_func : lambda;
@@ -338,6 +340,7 @@ let default_function_attribute = {
   stub = false;
   return_unit = false;
   async = false;
+  oneUnitArg = false;
 }
 
 let default_stub_attribute =
diff --git a/jscomp/ml/lambda.mli b/jscomp/ml/lambda.mli
@@ -271,6 +271,7 @@ type function_attribute = {
   stub: bool;
   return_unit : bool;
   async : bool;
+  oneUnitArg : bool;
 }
 
 type lambda =
diff --git a/jscomp/ml/translcore.ml b/jscomp/ml/translcore.ml
@@ -781,9 +781,17 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda =
       (* ReScript uncurried encoding *)
       let loc = expr.exp_loc in
       let lambda = transl_exp expr in
-      let arity_s = Ast_uncurried.uncurried_type_get_arity ~env:e.exp_env e.exp_type |> string_of_int in
+      let arity = Ast_uncurried.uncurried_type_get_arity ~env:e.exp_env e.exp_type in
+      let arity_s = arity |> string_of_int in
+      let name = match (Ctype.expand_head expr.exp_env expr.exp_type).desc with
+      | Tarrow (Nolabel, t, _, _) -> (
+        match (Ctype.expand_head expr.exp_env t).desc with
+        | Tconstr (Pident {name= "unit"}, [], _) -> "#fn_mk_unit"
+        | _ -> "#fn_mk"
+      )
+      | _ -> "#fn_mk" in
       let prim =
-        Primitive.make ~name:"#fn_mk" ~alloc:true ~native_name:arity_s
+        Primitive.make ~name ~alloc:true ~native_name:arity_s
           ~native_repr_args:[ Same_as_ocaml_repr ]
           ~native_repr_res:Same_as_ocaml_repr
       in
diff --git a/jscomp/ml/translmod.ml b/jscomp/ml/translmod.ml
@@ -277,6 +277,7 @@ let rec compile_functor mexp coercion root_path loc =
           stub = false;
           return_unit = false;
           async = false;
+          oneUnitArg = false;
         };
       loc;
       body;
diff --git a/jscomp/test/UncurriedExternals.js b/jscomp/test/UncurriedExternals.js
@@ -123,7 +123,7 @@ function tsiU$1(c) {
     });
 }
 
-var match$1 = React.useState(function (param) {
+var match$1 = React.useState(function () {
       return 3;
     });
 
diff --git a/jscomp/test/async_await.js b/jscomp/test/async_await.js
@@ -6,7 +6,7 @@ function next(n) {
   return n + 1 | 0;
 }
 
-async function useNext(param) {
+async function useNext() {
   return 4;
 }
 
@@ -19,7 +19,7 @@ function Make(I) {
         };
 }
 
-async function topFoo(param) {
+async function topFoo() {
   return 1;
 }
 
diff --git a/jscomp/test/event_ffi.js b/jscomp/test/event_ffi.js
@@ -38,7 +38,7 @@ function ocaml_run(b, c) {
   return (x + b | 0) + c | 0;
 }
 
-function a0(param) {
+function a0() {
   console.log("hi");
 }
 
diff --git a/jscomp/test/ffi_arity_test.js b/jscomp/test/ffi_arity_test.js
@@ -39,7 +39,7 @@ var hh = [
       return parseInt(x);
     });
 
-function u(param) {
+function u() {
   return 3;
 }
 
@@ -53,7 +53,7 @@ function fff(param) {
   vvv.contents = vvv.contents + 1 | 0;
 }
 
-function g(param) {
+function g() {
   fff(undefined);
 }
 
diff --git a/jscomp/test/mt.js b/jscomp/test/mt.js
@@ -230,7 +230,7 @@ function old_from_promise_suites_donotuse(name, suites) {
   var match = $$Array.to_list(Process.argv);
   if (match) {
     if (is_mocha(undefined)) {
-      describe(name, (function (param) {
+      describe(name, (function () {
               List.iter((function (param) {
                       var code = param[1];
                       it(param[0], (function (param) {
diff --git a/jscomp/test/pipe_send_readline.js b/jscomp/test/pipe_send_readline.js
@@ -4,7 +4,7 @@
 function u(rl) {
   return rl.on("line", (function (x) {
                   console.log(x);
-                })).on("close", (function (param) {
+                })).on("close", (function () {
                 console.log("finished");
               }));
 }
diff --git a/jscomp/test/ppx_apply_test.js b/jscomp/test/ppx_apply_test.js
@@ -29,7 +29,7 @@ function eq(loc, x, y) {
 
 var u = 3;
 
-function nullary(param) {
+function nullary() {
   return 3;
 }
 
diff --git a/jscomp/test/raw_output_test.js b/jscomp/test/raw_output_test.js
@@ -8,7 +8,7 @@ function mk(fn) {
 
 (((_)=> console.log('should works'))(undefined));
 
-console.log((function (param) {
+console.log((function () {
           return 1;
         })(undefined));
 
diff --git a/jscomp/test/reactTestUtils.js b/jscomp/test/reactTestUtils.js
@@ -7,14 +7,14 @@ var Caml_option = require("../../lib/js/caml_option.js");
 var TestUtils = require("react-dom/test-utils");
 
 function act(func) {
-  var reactFunc = function (param) {
+  var reactFunc = function () {
     Curry._1(func, undefined);
   };
   TestUtils.act(reactFunc);
 }
 
 function actAsync(func) {
-  return TestUtils.act(function (param) {
+  return TestUtils.act(function () {
               return Curry._1(func, undefined);
             });
 }
diff --git a/jscomp/test/tramp_fib.js b/jscomp/test/tramp_fib.js
@@ -20,7 +20,7 @@ function fib(n, k) {
   } else {
     return {
             TAG: "Suspend",
-            _0: (function (param) {
+            _0: (function () {
                 return fib(n - 1 | 0, (function (v0) {
                               return fib(n - 2 | 0, (function (v1) {
                                             return k(v0 + v1 | 0);
@@ -54,7 +54,7 @@ function isEven(n) {
     if (n !== 1) {
       return {
               TAG: "Suspend",
-              _0: (function (param) {
+              _0: (function () {
                   return isOdd(n - 1 | 0);
                 })
             };
diff --git a/jscomp/test/uncurried_cast.js b/jscomp/test/uncurried_cast.js
@@ -76,7 +76,7 @@ var StandardNotation = {
   anInt: anInt
 };
 
-function testRaise$1(param) {
+function testRaise$1() {
   throw {
         RE_EXN_ID: E,
         Error: new Error()
diff --git a/jscomp/test/uncurry_glob_test.js b/jscomp/test/uncurry_glob_test.js
@@ -8,7 +8,7 @@ function M(U) {
         };
 }
 
-function f(param) {
+function f() {
   return 3;
 }
 
diff --git a/jscomp/test/uncurry_test.js b/jscomp/test/uncurry_test.js
@@ -1,7 +1,7 @@
 'use strict';
 
 
-function f0(param) {
+function f0() {
   return 0;
 }
 
@@ -25,7 +25,7 @@ console.log([
       1
     ]);
 
-function xx(_param) {
+function xx() {
   while(true) {
     _param = undefined;
     continue ;
diff --git a/lib/es6/camlinternalLazy.js b/lib/es6/camlinternalLazy.js
diff --git a/lib/es6/pervasivesU.js b/lib/es6/pervasivesU.js
diff --git a/lib/js/camlinternalLazy.js b/lib/js/camlinternalLazy.js
diff --git a/lib/js/pervasivesU.js b/lib/js/pervasivesU.js

Original file line number	Diff line number	Diff line change
`@@ -204,7 +204,8 @@ let unit : t = { expression_desc = Undefined; comment = None }`
`204`	`204`	`[Js_fun_env.empty] is a mutable state ..`
`205`	`205`	`*)`
`206`	`206`
`207`		`-let ocaml_fun ?comment ?immutable_mask ~return_unit ~async params body : t =`
	`207`	`+let ocaml_fun ?comment ?immutable_mask ~return_unit ~async ~oneUnitArg params body : t =`
	`208`	`+ let params = if oneUnitArg then [] else params in`
`208`	`209`	`let len = List.length params in`
`209`	`210`	`{`
`210`	`211`	`expression_desc =`
Original file line number	Diff line number	Diff line change
`@@ -89,6 +89,7 @@ val ocaml_fun :`
`89`	`89`	`?immutable_mask:bool array ->`
`90`	`90`	`return_unit:bool ->`
`91`	`91`	`async:bool ->`
	`92`	`+ oneUnitArg:bool ->`
`92`	`93`	`J.ident list ->`
`93`	`94`	`J.block ->`
`94`	`95`	`t`