Merge pull request #2609 from BuckleScript/gpr_2608

fix #2608

Author: bobzhang

jscomp/core/bs_conditional_initial.ml

@@ -25,7 +25,7 @@
 
 let setup_env () = 
 #if BS_DEBUG then    
-    Js_config.set_debug_file "test_bool_equal.ml";
+    Js_config.set_debug_file "gpr_2608_test.ml";
 #end       
   Lexer.replace_directive_bool "BS" true;
   Lexer.replace_directive_string "BS_VERSION"  Bs_version.version

jscomp/core/js_output.ml

@@ -90,8 +90,9 @@ let output_of_block_and_expression
   | Assign n, ReturnFalse -> make (block @ [S.assign n exp])  
   | EffectCall, ReturnTrue _ -> make (block @ [S.return_stmt exp]) ~finished:True
   | (Declare _ | Assign _), ReturnTrue _ ->
-     make [S.unknown_lambda lam] ~finished:True
-  | NeedValue, _ ->  make block ~value:exp
+    make [S.unknown_lambda lam] ~finished:True
+  | NeedValue, (ReturnTrue _ | ReturnFalse) -> 
+    make block ~value:exp
 
 let statement_of_opt_expr (x : J.expression option) : J.statement =
   match x with 

jscomp/core/lam_compile.ml

@@ -51,7 +51,8 @@ let rec flat_catches acc (x : Lam.t)
     flat_catches ((code,handler,bindings)::acc) l
   | _ -> acc, x
 
-let flatten_caches  x = flat_catches [] x 
+let flatten_caches  x : (int * Lam.t * Ident.t  list ) list * Lam.t = 
+  flat_catches [] x 
 
 
 
@@ -101,12 +102,13 @@ type default_case =
       non-toplevel, it will explode code very quickly              
 *)    
 let rec  
-  compile_external_field 
+  compile_external_field (* Like [List.empty]*)
     (cxt : Lam_compile_context.t) 
-    lam 
+    (lam  : Lam.t)
     (id : Ident.t)
     (pos : int)
-    env : Js_output.t = 
+    (env : Env.t)
+  : Js_output.t = 
   let f =   Js_output.output_of_expression cxt.st cxt.should_return lam in    
   match Lam_compile_env.cached_find_ml_id_pos id pos env  with 
   | {id; name; closed_lambda } ->
@@ -151,17 +153,23 @@ let rec
 
 and compile_external_field_apply 
     (cxt : Lam_compile_context.t) 
-    lam 
-    args_lambda
+    (lam : Lam.t) (* original lambda*)
+    (args_lambda : Lam.t list)
     (id : Ident.t)
-    (pos : int) env : Js_output.t = 
-  match Lam_compile_env.cached_find_ml_id_pos 
-          id pos env with 
+    (pos : int)
+    (env : Env.t) : Js_output.t = 
+  match
+    Lam_compile_env.cached_find_ml_id_pos 
+      id pos env
+  with 
   | {id; name;arity; closed_lambda ; _} -> 
     let args_code, args = 
       Ext_list.fold_right 
         (fun (x : Lam.t) (args_code, args)  ->
-           match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} x with
+           match
+             compile_lambda
+               {cxt with st = NeedValue; should_return = ReturnFalse} x
+           with
            | {block = a; value = Some b} -> 
              (Ext_list.append a args_code), (b :: args )
            | _ -> assert false
@@ -223,8 +231,13 @@ and compile_external_field_apply
             args (List.length args ))
 
 
-and  compile_let let_kind (cxt : Lam_compile_context.t) id (arg : Lam.t) : Js_output.t =
-  compile_lambda {cxt with st = Declare (let_kind, id); should_return = ReturnFalse } arg 
+and  compile_let 
+  (let_kind : Lam_compile_context.let_kind)
+  (cxt : Lam_compile_context.t)
+  (id : J.ident)
+  (arg : Lam.t) : Js_output.t =
+  compile_lambda
+    {cxt with st = Declare (let_kind, id); should_return = ReturnFalse } arg 
 (** 
     The second return values are values which need to be wrapped using 
    [caml_update_dummy] 
@@ -339,7 +352,8 @@ and compile_recursive_let ~all_bindings
       | _ -> assert false 
     end
   | Lvar _   ->
-    compile_lambda {cxt with st = Declare (Alias ,id); should_return = ReturnFalse } arg, []
+    compile_lambda
+      {cxt with st = Declare (Alias ,id); should_return = ReturnFalse } arg, []
   | _ -> 
     (* pathological case:
         fail to capture taill call?
@@ -362,13 +376,16 @@ and compile_recursive_let ~all_bindings
              fun _-> print_endline "hey"; v ()
        ]}
     *)
-    compile_lambda {cxt with st = Declare (Alias ,id); should_return = ReturnFalse } arg, []
+    compile_lambda
+      {cxt with st = Declare (Alias ,id); should_return = ReturnFalse } arg, []
 
 and compile_recursive_lets_aux cxt id_args : Js_output.t = 
   (* #1716 *)
-  let output_code, ids  = Ext_list.fold_right
+  let output_code, ids  =
+    Ext_list.fold_right
       (fun (ident,arg) (acc, ids) -> 
-         let code, declare_ids  = compile_recursive_let ~all_bindings:id_args cxt ident arg in
+         let code, declare_ids  =
+           compile_recursive_let ~all_bindings:id_args cxt ident arg in
          (code ++ acc, Ext_list.append declare_ids  ids )
       )  id_args (Js_output.dummy, [])
   in
@@ -388,7 +405,8 @@ and compile_recursive_lets cxt id_args : Js_output.t  =
       | [ ] -> assert false 
       | first::rest  ->
         let acc = compile_recursive_lets_aux cxt first in 
-        List.fold_left (fun acc x -> acc ++ compile_recursive_lets_aux cxt x ) acc rest 
+        List.fold_left
+          (fun acc x -> acc ++ compile_recursive_lets_aux cxt x ) acc rest 
     end  
 and compile_general_cases : 
   'a . 
@@ -456,14 +474,18 @@ and compile_general_cases :
       in
       let body = 
         table 
-        |> Ext_list.stable_group (fun (_,lam) (_,lam1) -> Lam_analysis.eq_lambda lam lam1)
+        |> Ext_list.stable_group
+          (fun (_,lam) (_,lam1)
+            -> Lam_analysis.eq_lambda lam lam1)
         |> Ext_list.flat_map 
           (fun group -> 
              group 
              |> Ext_list.map_last 
                (fun last (x,lam) -> 
                   if last 
-                  then {J.case =  x; body = Js_output.to_break_block (compile_lambda cxt lam) }
+                  then {J.case =  x;
+                        body =
+                          Js_output.to_break_block (compile_lambda cxt lam) }
                   else { case = x; body = [],false }))
           (* TODO: we should also group default *)
           (* The last clause does not need [break]
@@ -472,11 +494,15 @@ and compile_general_cases :
       in
       [switch ?default ?declaration v body] 
 
-and compile_cases cxt = compile_general_cases (fun x -> E.small_int  x) E.int_equal cxt 
-    (fun  ?default ?declaration e clauses    -> S.int_switch ?default  ?declaration e clauses)
+and compile_cases cxt =
+  compile_general_cases (fun x -> E.small_int  x) E.int_equal cxt 
+    (fun  ?default ?declaration e clauses    ->
+       S.int_switch ?default  ?declaration e clauses)
 
-and compile_string_cases cxt = compile_general_cases E.str E.string_equal cxt 
-    (fun  ?default ?declaration e clauses    -> S.string_switch ?default  ?declaration e clauses)
+and compile_string_cases cxt =
+  compile_general_cases E.str E.string_equal cxt 
+    (fun  ?default ?declaration e clauses    ->
+       S.string_switch ?default  ?declaration e clauses)
 (* TODO: optional arguments are not good 
     for high order currying *)
 and
@@ -500,15 +526,15 @@ and
 
 
     | Lapply{
-        fn = Lapply{ fn = an; args =  args'; status = App_na ; };
+        fn = Lapply{ fn = an; args =  fn_args; status = App_na ; };
         args;  
         status = App_na; loc }
       ->    
       (* After inlining we can generate such code, 
          see {!Ari_regress_test}         
       *)      
       compile_lambda  cxt  
-        (Lam.apply an (Ext_list.append args'  args)  loc  App_na )
+        (Lam.apply an (Ext_list.append fn_args  args)  loc  App_na )
     (* External function calll *)
     | Lapply{ fn = 
                 Lprim{primitive = Pfield (n,_); 
@@ -650,43 +676,107 @@ and
           (* Invariant: if [should_return], then [st] will not be [NeedValue] *)
           ->
           compile_lambda cxt (Lam.sequand  l r )
-        | _ -> 
-          let l_block,l_expr = 
-            match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} l with 
-            | {block = a; value = Some b} -> a, b
-            | _ -> assert false 
-          in
-          let r_block, r_expr = 
-            match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} r with
-            | {block = a; value = Some b} -> a, b
-            | _ -> assert false 
-          in
-          let args_code =  Ext_list.append l_block  r_block  in
-          let exp =  E.and_ l_expr r_expr  in
-          Js_output.output_of_block_and_expression st should_return lam args_code exp           
+        | {should_return = ReturnFalse } -> 
+          let new_cxt = {cxt with st = NeedValue} in
+          match
+            compile_lambda new_cxt l with 
+          | { value = None } -> assert false   
+          | {block = l_block; value = Some l_expr} ->
+            match compile_lambda new_cxt r
+            with
+            | { value = None } -> assert false 
+            | {block = []; value = Some r_expr} 
+              ->               
+              Js_output.output_of_block_and_expression 
+                st 
+                should_return lam l_block (E.and_ l_expr r_expr)
+            | { block = r_block; value = Some r_expr} ->    
+              begin match cxt.st with 
+                | Assign v ->
+                  (* Refernece Js_output.output_of_block_and_expression *)
+                  Js_output.make
+                    (
+                      l_block @
+                      [S.if_ l_expr (r_block @ [ S.assign v r_expr])
+                         ~else_:[S.assign v E.caml_false]
+                      ]
+                    )
+                | Declare (_kind,v) ->
+                  (* Refernece Js_output.output_of_block_and_expression *)
+                  Js_output.make 
+                    (
+                      l_block @                
+                      [ S.define_variable ~kind:Variable v E.caml_false ; 
+                        S.if_ l_expr                  
+                          (r_block @ [S.assign v r_expr])])
+                | EffectCall
+                | NeedValue ->
+                  let v = Ext_ident.create_tmp () in 
+                  Js_output.make
+                    (S.define_variable ~kind:Variable v E.caml_false :: 
+                     l_block @
+                     [S.if_ l_expr                  
+                        (r_block @ [
+                            S.assign v r_expr
+                          ]
+                        )
+                     ]
+                    )
+                    ~value:(E.var v)                    
+              end
       end
-
     | Lprim {primitive = Psequor; args =  [l;r]}
       ->
       begin match cxt with
         | {should_return = ReturnTrue _ }
           (* Invariant: if [should_return], then [st] will not be [NeedValue] *)
           ->
           compile_lambda cxt @@ Lam.sequor l r
-        | _ ->
-          let l_block,l_expr =
-            match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} l with
-            | {block = a; value = Some b} -> a, b
-            | _ -> assert false
-          in
-          let r_block, r_expr =
-            match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} r with
-            | {block = a; value = Some b} -> a, b
-            | _ -> assert false
-          in
-          let args_code =  Ext_list.append l_block r_block  in
-          let exp =  E.or_ l_expr r_expr  in
-          Js_output.output_of_block_and_expression st should_return lam args_code exp
+        | {should_return = ReturnFalse } ->
+          let new_cxt = {cxt with st = NeedValue} in 
+          match compile_lambda new_cxt l with
+          | {value = None } -> assert false
+          | {block = l_block; value = Some l_expr} -> 
+            match compile_lambda new_cxt r with
+            | {value = None} -> assert false
+            | {block = []; value = Some r_expr} -> 
+              let exp =  E.or_ l_expr r_expr  in
+              Js_output.output_of_block_and_expression 
+                st should_return lam l_block exp
+            | {block = r_block; value = Some r_expr} ->
+              begin match cxt.st with 
+                | Assign v -> 
+                  (* Reference Js_output.output_of_block_and_expression *)
+                  Js_output.make 
+                    (l_block @ 
+                     [ S.if_ (E.not l_expr)
+                         (r_block @ [
+                             S.assign v r_expr
+                           ])
+                         ~else_:[S.assign v E.caml_true] ])
+                | Declare(_kind,v) ->
+                  Js_output.make 
+                    (
+                      l_block @  
+                      [ S.define_variable ~kind:Variable v E.caml_true;
+                        S.if_ (E.not l_expr)
+                          (r_block @ [S.assign v r_expr])
+                      ]
+                    )
+                | EffectCall
+                | NeedValue ->
+                  let v = Ext_ident.create_tmp () in 
+                  Js_output.make
+                    ( l_block @ 
+                      [S.define_variable ~kind:Variable v E.caml_true;
+                       S.if_ (E.not l_expr)
+                         (r_block @ [
+                             S.assign v r_expr
+                           ])
+                      ]
+                    )
+                    ~value:(E.var v)
+              end
       end
     | Lprim {primitive = Pdebugger ; _}
       -> 
@@ -1154,7 +1244,9 @@ and
              when branches are minimial (less than 2)
           *)
           let v = Ext_ident.create_tmp () in
-          Js_output.make (S.declare_variable ~kind:Variable v   :: compile_whole {cxt with st = Assign v})
+          Js_output.make 
+            (S.declare_variable ~kind:Variable v   :: 
+              compile_whole {cxt with st = Assign v})
             ~value:(E.var  v)
 
         | Declare (kind,id) -> 

jscomp/test/.depend

@@ -304,6 +304,7 @@ gpr_2316_test.cmj : mt.cmj ../runtime/js.cmj
 gpr_2474.cmj :
 gpr_2487.cmj : ../others/belt.cmj
 gpr_2503_test.cmj : mt.cmj ../runtime/js.cmj
+gpr_2608_test.cmj : mt.cmj ../stdlib/list.cmj
 gpr_405_test.cmj : ../stdlib/hashtbl.cmj gpr_405_test.cmi
 gpr_441.cmj :
 gpr_459_test.cmj : mt.cmj

jscomp/test/Makefile

@@ -241,6 +241,7 @@ OTHERS := test_literals a test_ari test_export2 test_internalOO test_obj_simple_
 	gpr_2487\
 	gpr_2503_test\
 	block_alias_test\
+	gpr_2608_test\
 # bs_uncurry_test
 # needs Lam to get rid of Uncurry arity first
 # simple_derive_test

jscomp/test/bs_hashtbl_string_test.js

@@ -23,7 +23,7 @@ var hashString = (function (str) {
                                               while(i !== 0) {
                                               hash = (hash * 33) ^ str.charCodeAt(--i);
                                               }
-                                              return hash  
+                                              return hash
                                               }
                                             );
 

jscomp/test/ext_string_test.js

@@ -59,15 +59,23 @@ function trim(s) {
   var i = 0;
   var j = s.length;
   while((function () {
-          var u = s.charCodeAt(i);
-          return +(i < j && (u === /* "\t" */9 || u === /* "\n" */10 || u === /* " " */32));
+          var tmp = /* false */0;
+          if (i < j) {
+            var u = s.charCodeAt(i);
+            tmp = +(u === /* "\t" */9 || u === /* "\n" */10 || u === /* " " */32);
+          }
+          return tmp;
         })()) {
     i = i + 1 | 0;
   };
   var k = j - 1 | 0;
   while((function () {
-          var u = s.charCodeAt(k);
-          return +(k >= i && (u === /* "\t" */9 || u === /* "\n" */10 || u === /* " " */32));
+          var tmp = /* false */0;
+          if (k >= i) {
+            var u = s.charCodeAt(k);
+            tmp = +(u === /* "\t" */9 || u === /* "\n" */10 || u === /* " " */32);
+          }
+          return tmp;
         })()) {
     k = k - 1 | 0;
   };