Refine tail position property

Author: bobzhang

jscomp/core/js_output.ml

@@ -54,15 +54,15 @@ let output_of_expression
     (continuation : continuation)
     (exp : J.expression) ~(no_effects: bool Lazy.t)  =
   match continuation with
-  | EffectCall  ReturnFalse ->
+  | EffectCall  Not_tail ->
     if Lazy.force no_effects 
     then dummy
     else {block = []; value  = Some exp ; output_finished = False}
   | Declare (kind, n)->
     make [ S.define_variable ~kind n  exp]
   | Assign n  ->
     make [S.assign n exp ]
-  | EffectCall (ReturnTrue _) ->
+  | EffectCall (Maybe_tail _) ->
     make [S.return_stmt  exp] ~output_finished:True
   | NeedValue _ ->
     {block = []; value = Some exp; output_finished = False }
@@ -72,8 +72,8 @@ let output_of_block_and_expression
     (continuation : continuation)
     (block : J.block) exp : t =
   match continuation with
-  | EffectCall ReturnFalse -> make block ~value:exp
-  | EffectCall (ReturnTrue _) -> 
+  | EffectCall Not_tail -> make block ~value:exp
+  | EffectCall (Maybe_tail _) -> 
     make (Ext_list.append_one block (S.return_stmt exp)) ~output_finished:True
   | Declare (kind,n) ->
     make (Ext_list.append_one block (S.define_variable ~kind  n exp))

jscomp/core/lam_compile.ml

@@ -28,6 +28,14 @@ module S = Js_stmt_make
 
 let method_cache_id = ref 1 (*TODO: move to js runtime for re-entrant *)
 
+let change_return_type_in_try 
+  (x : Lam_compile_context.tail_type)
+  : Lam_compile_context.tail_type = 
+  match x with 
+  | Maybe_tail (Tail_with_name _ | Tail_no_name_lambda) ->
+    Maybe_tail Tail_in_try
+  | Not_tail | Maybe_tail Tail_in_try
+    -> x
 
 (* assume outer is [Lstaticcatch] *)
 let rec flat_catches (acc : Lam_compile_context.handler list) (x : Lam.t)
@@ -159,7 +167,7 @@ and compile_external_field_apply
       let dummy = [], [] in 
       if args_lambda = [] then dummy
       else 
-        let arg_cxt = {lambda_cxt with continuation = NeedValue ReturnFalse} in 
+        let arg_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in 
         Ext_list.fold_right args_lambda dummy (fun arg_lambda  (args_code, args)  ->
            match compile_lambda arg_cxt arg_lambda with
            | {block; value = Some b} ->
@@ -253,7 +261,7 @@ and compile_recursive_let ~all_bindings
     let output =
       compile_lambda
         { cxt with
-          continuation = EffectCall (ReturnTrue (Some ret ));
+          continuation = EffectCall (Maybe_tail (Tail_with_name ret ));
           jmp_table = Lam_compile_context.empty_handler_map}  body in
     let result =
       if ret.triggered then
@@ -317,7 +325,7 @@ and compile_recursive_let ~all_bindings
     *)
     (* Ext_log.err "@[recursive value %s/%d@]@." id.name id.stamp; *)
     begin
-      match compile_lambda {cxt with continuation = NeedValue ReturnFalse } arg with
+      match compile_lambda {cxt with continuation = NeedValue Not_tail } arg with
       | { block = b; value = Some v} ->
         (* TODO: check recursive value ..
             could be improved for simple cases
@@ -534,7 +542,7 @@ and compile_switch switch_arg sw (lambda_cxt : Lam_compile_context.t) =
       else Default x in
   let compile_whole  (cxt  : Lam_compile_context.t ) =
     match compile_lambda 
-            {cxt with  continuation = NeedValue ReturnFalse}
+            {cxt with  continuation = NeedValue Not_tail}
             switch_arg
     with
     | {value =  None; _}  -> assert false
@@ -598,7 +606,7 @@ and compile_stringswitch l cases default (lambda_cxt : Lam_compile_context.t) =
   *)
   match 
     compile_lambda 
-      {lambda_cxt with continuation = NeedValue ReturnFalse } l
+      {lambda_cxt with continuation = NeedValue Not_tail } l
   with
   | {value = None } -> assert false
   | {block ; value =  Some e}  ->
@@ -731,7 +739,7 @@ and compile_sequand
     if Lam_compile_context.continuation_is_return lambda_cxt.continuation then
       compile_lambda lambda_cxt (Lam.sequand  l r )
     else
-      let new_cxt = {lambda_cxt with continuation = NeedValue ReturnFalse} in
+      let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in
       match compile_lambda new_cxt l with
       | { value = None } -> assert false
       | {block = l_block; value = Some l_expr} ->
@@ -780,7 +788,7 @@ and compile_sequor
     if Lam_compile_context.continuation_is_return lambda_cxt.continuation then  
       compile_lambda lambda_cxt (Lam.sequor l r)
     else
-      let new_cxt = {lambda_cxt with continuation = NeedValue ReturnFalse} in
+      let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in
       match compile_lambda new_cxt l with
       | {value = None } -> assert false
       | {block = l_block; value = Some l_expr} ->
@@ -830,7 +838,7 @@ and compile_sequor
             (Sine OCaml expression can be really complex..)
 *)
 and compile_while (predicate : Lam.t) (body : Lam.t) (lambda_cxt : Lam_compile_context.t) =              
-    match compile_lambda {lambda_cxt with continuation = NeedValue ReturnFalse } predicate
+    match compile_lambda {lambda_cxt with continuation = NeedValue Not_tail } predicate
     with
     | { value = None} -> assert false
     | { block; value =  Some e} ->
@@ -845,7 +853,7 @@ and compile_while (predicate : Lam.t) (body : Lam.t) (lambda_cxt : Lam_compile_c
             e
             (Js_output.output_as_block @@
              compile_lambda
-               {lambda_cxt with continuation = EffectCall ReturnFalse}
+               {lambda_cxt with continuation = EffectCall Not_tail}
                body)
         ] in
       Js_output.output_of_block_and_expression lambda_cxt.continuation block E.unit
@@ -864,7 +872,7 @@ and compile_while (predicate : Lam.t) (body : Lam.t) (lambda_cxt : Lam_compile_c
 
 and compile_for 
     id start finish direction body (lambda_cxt : Lam_compile_context.t) = 
-    let new_cxt = {lambda_cxt with continuation = NeedValue ReturnFalse} in 
+    let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in 
     let block =
       match compile_lambda new_cxt start,
             compile_lambda new_cxt finish with
@@ -883,7 +891,7 @@ and compile_for
         *)
         let block_body = 
           Js_output.output_as_block 
-            (compile_lambda {lambda_cxt with  continuation = EffectCall ReturnFalse}
+            (compile_lambda {lambda_cxt with  continuation = EffectCall Not_tail}
                body) in 
         match b1,b2 with
         | _,[] ->
@@ -916,7 +924,7 @@ and compile_assign id (lambda : Lam.t) (lambda_cxt : Lam_compile_context.t) =
         ]
       | _ ->        
         match compile_lambda 
-                {lambda_cxt with continuation = NeedValue ReturnFalse} 
+                {lambda_cxt with continuation = NeedValue Not_tail} 
                 lambda 
         with
         | {value = None} -> assert false
@@ -959,10 +967,14 @@ and compile_trywith lam id catch (lambda_cxt : Lam_compile_context.t) =
       let context = {lambda_cxt with continuation = Assign v} in 
       Js_output.make (S.declare_variable ~kind:Variable v :: 
                       aux context context)  ~value:(E.var v )
-    | EffectCall (ReturnTrue (Some _)) -> 
-      Js_output.make (aux lambda_cxt {lambda_cxt with continuation = EffectCall (ReturnTrue None)} )
-    | EffectCall _ -> 
-      Js_output.make (aux lambda_cxt lambda_cxt)
+    | EffectCall return_type -> 
+      let new_return_type = change_return_type_in_try return_type in 
+      if new_return_type == return_type then 
+        Js_output.make (aux lambda_cxt lambda_cxt)
+      else 
+        Js_output.make (aux lambda_cxt {lambda_cxt with continuation = EffectCall new_return_type} )
+
+      
 
 (* Note that in [Texp_apply] for [%sendcache] the cache might not be used
    see {!CamlinternalOO.send_meth} and {!Translcore.transl_exp0} the branch
@@ -1012,7 +1024,7 @@ and compile_send  (meth_kind : Lam_compat.meth_kind)
     (met : Lam.t) 
     (obj : Lam.t) (args : Lam.t list) loc 
     (lambda_cxt : Lam_compile_context.t) =       
-    let new_cxt = {lambda_cxt with continuation = NeedValue ReturnFalse} in 
+    let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in 
     match Ext_list.split_map (met :: obj :: args) (fun x  ->
           match x with
           | Lprim {primitive = Pccall {prim_name ; _}; args =  []}
@@ -1079,7 +1091,7 @@ and compile_ifthenelse
       (t_branch : Lam.t)
       (f_branch : Lam.t)
       (lambda_cxt : Lam_compile_context.t) = 
-    match compile_lambda {lambda_cxt with continuation = NeedValue ReturnFalse } predicate with
+    match compile_lambda {lambda_cxt with continuation = NeedValue Not_tail } predicate with
     | {value = None } -> assert false    
     | {block = b; value =  Some e} ->
       match lambda_cxt.continuation with
@@ -1108,7 +1120,7 @@ and compile_ifthenelse
               ~value:(E.var id)
         )
       | Declare (kind,id) ->
-        let declare_cxt = {lambda_cxt with continuation = NeedValue ReturnFalse} in 
+        let declare_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in 
         (match 
            compile_lambda declare_cxt t_branch,
            compile_lambda declare_cxt f_branch with
@@ -1140,7 +1152,7 @@ and compile_ifthenelse
                compile_lambda context1  f_branch with
 
         (* see PR#83 *)
-        |  ReturnFalse , {block = []; value =  Some out1},
+        |  Not_tail , {block = []; value =  Some out1},
            {block = []; value =  Some out2} ->            
           (match Js_exp_make.remove_pure_sub_exp out1 ,
                  Js_exp_make.remove_pure_sub_exp out2 with
@@ -1152,7 +1164,7 @@ and compile_ifthenelse
             Js_output.make (Ext_list.append_one b  (S.if_ e  [S.exp out1]))
           | None, Some out2 ->
             Js_output.make (Ext_list.append_one b  (S.if_ (E.not e) [S.exp out2])))
-        |  ReturnFalse , {block = []; value = Some out1}, _ ->
+        |  Not_tail , {block = []; value = Some out1}, _ ->
           (* assert branch
               TODO: here we re-compile two branches since
               its context is different -- could be improved
@@ -1171,7 +1183,7 @@ and compile_ifthenelse
                                             (compile_lambda lambda_cxt f_branch))]
               )
 
-        | ReturnFalse , _, {block = []; value = Some out2} ->
+        | Not_tail , _, {block = []; value = Some out2} ->
           let else_ =
             if  Js_analyzer.no_side_effect_expression out2 then
               None
@@ -1184,7 +1196,7 @@ and compile_ifthenelse
                   (Js_output.output_as_block (
                       compile_lambda lambda_cxt t_branch))
                   ?else_))
-        | ReturnTrue _, {block = []; value =  Some out1},
+        | Maybe_tail _, {block = []; value =  Some out1},
           {block = []; value =  Some out2} ->
           Js_output.make
             (Ext_list.append_one b  (S.return_stmt  (E.econd e  out1 out2)))
@@ -1228,7 +1240,7 @@ and compile_apply
          1. check arity, can be simplified for pure expression
          2. no need create names
       *)
-      let new_cxt = {lambda_cxt with continuation = NeedValue ReturnFalse} in 
+      let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in 
       let [@warning "-8" (* non-exhaustive pattern*)] (args_code, fn_code:: args) =
         Ext_list.fold_right (fn::args_lambda) ([],[]) (fun x  (args_code, fn_code )->
             match compile_lambda new_cxt x with
@@ -1237,7 +1249,7 @@ and compile_apply
           )  in
       match fn, lambda_cxt.continuation with
       | (Lvar fn_id,
-         (EffectCall (ReturnTrue (Some ret)) | NeedValue (ReturnTrue (Some   ret))))
+         (EffectCall (Maybe_tail (Tail_with_name ret)) | NeedValue (Maybe_tail (Tail_with_name ret))))
         when Ident.same ret.id fn_id ->
         ret.triggered <- true;
         (* Here we mark [finished] true, since the continuation
@@ -1289,7 +1301,7 @@ and compile_prim (prim_info : Lam.prim_info) (lambda_cxt : Lam_compile_context.t
       -> (* should be before Lglobal_global *)
       compile_external_field lambda_cxt id n lambda_cxt.meta.env
     | {primitive = Praise ; args =  [ e ]; _} ->      
-      (match compile_lambda {lambda_cxt with  continuation = NeedValue ReturnFalse} e with
+      (match compile_lambda {lambda_cxt with  continuation = NeedValue Not_tail} e with
        | {block ; value =  Some v} ->
          Js_output.make
            (Ext_list.append_one block  (S.throw_stmt v))
@@ -1320,7 +1332,7 @@ and compile_prim (prim_info : Lam.prim_info) (lambda_cxt : Lam_compile_context.t
          either a getter {[ x #. height ]} or {[ x ## method_call ]}
       *)
       let property =  Lam_methname.translate ~loc name  in      
-      (match compile_lambda {lambda_cxt with continuation = NeedValue ReturnFalse} obj
+      (match compile_lambda {lambda_cxt with continuation = NeedValue Not_tail} obj
        with
        | {value = None} -> assert false
        | {block; value = Some b } ->
@@ -1348,7 +1360,7 @@ and compile_prim (prim_info : Lam.prim_info) (lambda_cxt : Lam_compile_context.t
            args = [obj]} as fn;
           arg]
          ->
-         let need_value_no_return_cxt = {lambda_cxt with continuation = NeedValue ReturnFalse} in
+         let need_value_no_return_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in
          let obj_output = compile_lambda  need_value_no_return_cxt obj in
          let arg_output = compile_lambda need_value_no_return_cxt arg in
          let cont obj_block arg_block obj_code =
@@ -1420,7 +1432,7 @@ and compile_prim (prim_info : Lam.prim_info) (lambda_cxt : Lam_compile_context.t
               *)
               (Js_output.output_as_block
                  ( compile_lambda
-                     { lambda_cxt with continuation = EffectCall ( ReturnTrue None);                                 
+                     { lambda_cxt with continuation = EffectCall ( Maybe_tail Tail_no_name_lambda);                                 
                                        jmp_table = Lam_compile_context.empty_handler_map}
                      body)))
        | _ -> assert false)      
@@ -1435,7 +1447,7 @@ and compile_prim (prim_info : Lam.prim_info) (lambda_cxt : Lam_compile_context.t
       let args_block, args_expr =
         if args = [] then [], []
         else 
-          let new_cxt = {lambda_cxt with continuation = NeedValue ReturnFalse} in 
+          let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in 
           Ext_list.split_map args (fun x ->
               match compile_lambda new_cxt  x with
               | {block ; value = Some b} -> block,b
@@ -1448,7 +1460,7 @@ and compile_prim (prim_info : Lam.prim_info) (lambda_cxt : Lam_compile_context.t
     | {primitive; args; loc} ->
       let args_block, args_expr =
         if args = [] then [], []
-        else let new_cxt = {lambda_cxt with continuation = NeedValue ReturnFalse} in 
+        else let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in 
         Ext_list.split_map args (fun x ->
             match compile_lambda new_cxt x with
             | {block ; value = Some b} -> block,b
@@ -1473,7 +1485,7 @@ and compile_lambda
            (Js_output.output_as_block
               ( compile_lambda
                   { lambda_cxt with 
-                    continuation = EffectCall (ReturnTrue None); (* Refine*)
+                    continuation = EffectCall (Maybe_tail Tail_no_name_lambda); 
                     jmp_table = Lam_compile_context.empty_handler_map}
                   body)))
     | Lapply appinfo -> 
@@ -1516,7 +1528,7 @@ and compile_lambda
         compile_prim prim_info lambda_cxt
     | Lsequence (l1,l2) ->
       let output_l1 =
-        compile_lambda {lambda_cxt with continuation = EffectCall ReturnFalse} l1 in
+        compile_lambda {lambda_cxt with continuation = EffectCall Not_tail} l1 in
       let output_l2 =
         compile_lambda lambda_cxt l2  in
       Js_output.append_output output_l1  output_l2

jscomp/core/lam_compile_context.ml

@@ -46,12 +46,17 @@ type return_label = {
   mutable triggered : bool
 }
 
-type return_type = 
-  | ReturnFalse 
-  | ReturnTrue of return_label option 
+type maybe_tail = 
+  | Tail_in_try
+  | Tail_no_name_lambda
+  | Tail_with_name of return_label
+
+type tail_type = 
+  | Not_tail 
+  | Maybe_tail of maybe_tail
   (* Note [return] does indicate it is a tail position in most cases
      however, in an exception handler, return may not be in tail position
-     to fix #1701 we play a trick that (ReturnTrue None) 
+     to fix #1701 we play a trick that (Maybe_tail None) 
      would never trigger tailcall, however, it preserves [return] 
      semantics
   *)
@@ -61,18 +66,18 @@ type return_type =
 type let_kind = Lam_compat.let_kind
 
 type continuation = 
-  | EffectCall of return_type
-  | NeedValue of return_type
+  | EffectCall of tail_type
+  | NeedValue of tail_type
   | Declare of let_kind * J.ident (* bound value *)
   | Assign of J.ident (* when use [Assign], var is not needed, since it's already declared  *)
 
 type jmp_table =   value  HandlerMap.t
 
 let continuation_is_return ( x : continuation) =  
   match x with 
-  | EffectCall (ReturnTrue _) | NeedValue (ReturnTrue _) 
+  | EffectCall (Maybe_tail _) | NeedValue (Maybe_tail _) 
     -> true 
-  | EffectCall ReturnFalse | NeedValue ReturnFalse 
+  | EffectCall Not_tail | NeedValue Not_tail 
   | Declare _ | Assign _
     -> false
 

jscomp/core/lam_compile_context.mli

@@ -57,17 +57,23 @@ type value = {
 
 type let_kind = Lam_compat.let_kind
 
-type return_type = 
-  | ReturnFalse 
-  | ReturnTrue of return_label option (* anonoymous function does not have identifier *)
+type maybe_tail = 
+    | Tail_in_try
+    | Tail_no_name_lambda
+    | Tail_with_name of return_label 
+
+type tail_type = 
+  | Not_tail 
+  | Maybe_tail of maybe_tail
+  (* anonoymous function does not have identifier *)
 
 (* delegate to the callee to generate expression 
       Invariant: [output] should return a trailing expression
   *)
 
 type continuation = 
-  | EffectCall of return_type
-  | NeedValue of return_type
+  | EffectCall of tail_type
+  | NeedValue of tail_type
   | Declare of let_kind * J.ident (* bound value *)
   | Assign of J.ident 
   (** when use [Assign], var is not needed, since it's already declared