Eta conversion bug (#223)

* fix a bug in such case

```
f x --> function(y){ return f(x,y)}
```
only when x is a variable makes sense

Author: bobzhang

jscomp/lam_pass_alpha_conversion.ml

@@ -41,13 +41,35 @@ let alpha_conversion (meta : Lam_stats.meta) (lam : Lambda.lambda) : Lambda.lamb
                               List.map simpl ll, {info with apply_status = Full} )
               else if x > len  
               then 
-                let extra_args = Ext_list.init (x - len) (fun _ ->   (Ident.create "param")) in 
-                Lfunction(Curried, extra_args, 
-                          Lapply(simpl l1,
-                                 List.map simpl ll @ 
-                                 List.map (fun x -> Lambda.Lvar x) extra_args ,
-                                 {info with  apply_status = Full}
-                                ))
+                (* Lapply(simpl l1, List.map simpl ll,  info ) *)
+                let extra_args = Ext_list.init (x - len)
+                    (fun _ ->   (Ident.create "param")) in
+                let fn = simpl l1 in
+                let args = List.map simpl ll in
+                let extra_lambdas = List.map (fun x -> Lambda.Lvar x) extra_args in
+                let args, bindings =
+                  List.fold_right (fun lam (acc, bind) ->
+                      match lam with
+                      | Lambda.Lvar _
+                      | Lconst (Const_base _ | Const_pointer _ | Const_immstring _ ) 
+                      | Lprim (Lambda.Pfield (_), [Lprim (Lambda.Pgetglobal _, _)] )
+                      | Lfunction _ 
+                        ->
+                        (lam :: acc, bind)
+                      | _ ->
+                        let v = Ident.create Literals.partial_arg in
+                        (Lambda.Lvar v :: acc),  ((v, lam) :: bind)
+                    ) args ([],[])   in 
+                (* let args, bindings = args, [] in *)
+                let rest : Lambda.lambda = 
+                  Lfunction(Curried, extra_args,
+                            Lapply(fn,
+                                   args @ extra_lambdas ,
+                                   {info with  apply_status = Full}
+                                  )) in
+                List.fold_left (fun lam (id,x) ->
+                      Lambda.Llet (Strict, id, x,lam)
+                    ) rest bindings
                                   (*
                                     let f x y =  x + y 
                                     Invariant: there is no currying 

jscomp/lam_pass_lets_dce.ml

@@ -165,8 +165,10 @@ let lets_helper (count_var : Ident.t -> used_info) lam =
         | {times = 1; captured = false }, _ 
         | {times = 1; captured = true }, (Lconst _ | Lvar _)
         |  _, (Lconst (Const_base (
-            Const_int _ | Const_char _ | Const_float _ | Const_int32 _ 
-          | Const_nativeint _ ))) 
+              Const_int _ | Const_char _ | Const_float _ | Const_int32 _ 
+              | Const_nativeint _ ))
+              (* | Lprim (Lambda.Pfield (_), [Lprim (Lambda.Pgetglobal _, _)] ) *)
+            ) 
           (* Const_int64 is no longer primitive
              Note for some constant which is not 
              inlined, we can still record it and

jscomp/literals.ml

@@ -25,3 +25,6 @@ let js_type_string = "string"
 let js_type_object = "object" 
 let js_undefined = "undefined"
 let js_prop_length = "length"
+
+let param = "param"
+let partial_arg = "partial_arg"

jscomp/literals.mli

@@ -24,3 +24,6 @@ val js_type_string : string
 val js_type_object : string
 val js_undefined : string
 val js_prop_length : string
+
+val param : string
+val partial_arg : string

jscomp/stdlib/lexing.js

@@ -47,10 +47,11 @@ var zero_pos = /* record */[
 ];
 
 function from_function(f) {
+  var partial_arg = new Array(512);
   return /* record */[
           function (param) {
             var read_fun = f;
-            var aux_buffer = new Array(512);
+            var aux_buffer = partial_arg;
             var lexbuf = param;
             var read = Caml_curry.app2(read_fun, aux_buffer, aux_buffer.length);
             var n = read > 0 ? read : (lexbuf[/* lex_eof_reached */8] = /* true */1, 0);

jscomp/test/.depend

@@ -244,6 +244,8 @@ obj_test.cmo : mt.cmi
 obj_test.cmx : mt.cmx
 of_string_test.cmo : mt.cmi
 of_string_test.cmx : mt.cmx
+pr_regression_test.cmo : mt.cmi
+pr_regression_test.cmx : mt.cmx
 primitive_reg_test.cmo :
 primitive_reg_test.cmx :
 printf_sim.cmo : ../stdlib/printf.cmi
@@ -736,6 +738,8 @@ obj_test.cmo : mt.cmi
 obj_test.cmj : mt.cmj
 of_string_test.cmo : mt.cmi
 of_string_test.cmj : mt.cmj
+pr_regression_test.cmo : mt.cmi
+pr_regression_test.cmj : mt.cmj
 primitive_reg_test.cmo :
 primitive_reg_test.cmj :
 printf_sim.cmo : ../stdlib/printf.cmi

jscomp/test/pr_regression_test.js

@@ -0,0 +1,89 @@
+// Generated CODE, PLEASE EDIT WITH CARE
+'use strict';
+
+var Mt         = require("./mt");
+var Caml_curry = require("../runtime/caml_curry");
+
+var v = [3];
+
+function f(h) {
+  ++ v[0];
+  var partial_arg = 3;
+  return function (param) {
+    return Caml_curry.app2(h, partial_arg, param);
+  };
+}
+
+f(function (prim, prim$1) {
+      return prim + prim$1;
+    });
+
+f(function (prim, prim$1) {
+      return prim + prim$1;
+    });
+
+var a = v[0];
+
+var v$1 = [3];
+
+function f$1(h) {
+  ++ v$1[0];
+  var partial_arg = 3;
+  return function (param) {
+    return Caml_curry.app2(h, partial_arg, param);
+  };
+}
+
+f$1(function (prim, prim$1) {
+      return prim + prim$1;
+    });
+
+f$1(function (prim, prim$1) {
+      return prim + prim$1;
+    });
+
+var b = v$1[0];
+
+var v$2 = [3];
+
+function f$2(h) {
+  return Caml_curry.app2(h, 2, (++ v$2[0], 3));
+}
+
+f$2(function (prim, prim$1) {
+      return prim + prim$1;
+    });
+
+f$2(function (prim, prim$1) {
+      return prim + prim$1;
+    });
+
+var c = v$2[0];
+
+Mt.from_pair_suites("pr_regression_test.ml", /* :: */[
+      /* tuple */[
+        "partial",
+        function () {
+          return /* Eq */{
+                  0: /* tuple */[
+                    5,
+                    5,
+                    5
+                  ],
+                  1: /* tuple */[
+                    a,
+                    b,
+                    c
+                  ],
+                  length: 2,
+                  tag: 0
+                };
+        }
+      ],
+      /* [] */0
+    ]);
+
+exports.a = a;
+exports.b = b;
+exports.c = c;
+/*  Not a pure module */

jscomp/test/pr_regression_test.ml

@@ -0,0 +1,36 @@
+
+
+let a = 
+  let v = ref 3 in 
+  let action () =  incr v in
+  let  f h   = 
+    (fun x y -> h x y) (action (); 3) in 
+  ignore @@ f (+);
+  ignore @@ f (+);
+  !v 
+
+let b = 
+  let v = ref 3 in 
+  let action () =  incr v in
+  let  f h   = 
+    (fun x y -> h x y)  (action (); 3) in 
+  ignore @@ f (+);
+  ignore @@ f (+);
+  !v 
+
+let c = 
+  let v = ref 3 in 
+  let action () =  incr v in
+  let  f h   = 
+    (fun x y -> h x y)  2 (action (); 3) in 
+  ignore @@ f (+);
+  ignore @@ f (+);
+  !v 
+
+(* ;; Printf.printf "%d%d%d\n" a b c  *)
+
+;; Mt.from_pair_suites __FILE__ Mt.[
+  "partial", (fun _ -> Eq((5,5,5), (a,b,c)))
+]
+
+

jscomp/test/qcc.js

@@ -2180,11 +2180,13 @@ function main() {
   var f = Sys.argv.length < 2 ? "-blk" : Sys.argv[1];
   switch (f) {
     case "-blk" : 
+        var partial_arg_000 = [0];
+        var partial_arg = /* tuple */[
+          partial_arg_000,
+          0
+        ];
         var c = function (param) {
-          return block(/* tuple */[
-                      [0],
-                      0
-                    ], param);
+          return block(partial_arg, param);
         };
         var stk = /* [] */0;
         opos[0] = 0;

jscomp/test/test.mllib

@@ -213,4 +213,5 @@ printf_sim
 test_external_unit
 ext_array
 int32_test
-hamming_test
+hamming_test
+pr_regression_test