Compiler: loops no longer absorb the entire continuation

compiler/lib/generate.ml

@@ -842,6 +842,58 @@ let build_graph ctx pc =
   in
   loop pc Addr.Set.empty [];
   Hashtbl.add preds pc 1;
+  let () =
+    (* Create an artificial frontier when for-loops are not longer necessary *)
+    let loopback = Hashtbl.create 17 in
+    let rec loop pc loop_headers =
+      match Hashtbl.find loopback pc with
+      | x -> x
+      | exception Not_found ->
+          let loop_headers =
+            if Addr.Set.mem pc !loops then Addr.Set.add pc loop_headers else loop_headers
+          in
+          let backs = Hashtbl.find backs pc in
+          let all_backs =
+            List.fold_left (Hashtbl.find succs pc) ~init:backs ~f:(fun acc pc ->
+                Addr.Set.union acc (loop pc loop_headers))
+            |> Addr.Set.inter loop_headers
+          in
+          Hashtbl.replace loopback pc all_backs;
+          all_backs
+    in
+    ignore (loop pc Addr.Set.empty);
+    let compute_exit_loop pc_loop =
+      let visited = Hashtbl.create 18 in
+      let rec find pc_loops pc acc =
+        if Hashtbl.mem visited pc
+        then acc
+        else if Addr.Set.cardinal (Addr.Set.inter pc_loops (Hashtbl.find loopback pc)) = 0
+        then Addr.Set.add pc acc
+        else
+          let pc_loops =
+            if Addr.Set.mem pc !loops then Addr.Set.add pc pc_loops else pc_loops
+          in
+          let block = Addr.Map.find pc blocks in
+          let succs =
+            match block.branch with
+            | Pushtrap ((_pc1, _), _, (pc_exn, _), _) ->
+                Addr.Set.add pc_exn (Hashtbl.find poptrap pc) |> Addr.Set.elements
+            | _ -> Hashtbl.find succs pc
+          in
+          List.fold_left succs ~init:acc ~f:(fun acc pc' -> find pc_loops pc' acc)
+      in
+      find (Addr.Set.singleton pc_loop) pc_loop Addr.Set.empty
+    in
+    let get_ancestor pc =
+      Hashtbl.fold (fun k l acc -> if List.mem pc ~set:l then k :: acc else acc) succs []
+    in
+    Addr.Set.iter
+      (fun pc_loop ->
+        let set = compute_exit_loop pc_loop in
+        let preds = get_ancestor pc_loop in
+        List.iter preds ~f:(fun pc_loop_anc -> add_cf_frontier pc_loop_anc set))
+      !loops
+  in
   let () =
     (* Create an artificial frontier when we pop an exception handler *)
     let rec keep_front pc =
@@ -1576,6 +1628,10 @@ and compile_block st queue (pc : Addr.t) loop_stack frontier interm =
     | false -> compile_block_no_loop st queue pc loop_stack frontier interm
     | true ->
         if debug () then Format.eprintf "@[<hv 2>for(;;) {@,";
+        let grey = dominance_frontier st pc in
+        let exit_prefix, exit_cont, exit_interm, merge_node =
+          colapse_frontier "for-loop" st grey interm
+        in
         let never_body, body =
           let lab =
             match loop_stack with
@@ -1585,7 +1641,13 @@ and compile_block st queue (pc : Addr.t) loop_stack frontier interm =
           let lab_used = ref false in
           let loop_stack = (pc, (lab, lab_used)) :: loop_stack in
           let never_body, body =
-            compile_block_no_loop st queue pc loop_stack frontier interm
+            compile_block_no_loop
+              st
+              queue
+              pc
+              loop_stack
+              (Addr.Set.union frontier exit_cont)
+              exit_interm
           in
           let body =
             let rec remove_tailing_continue acc = function
@@ -1618,7 +1680,10 @@ and compile_block st queue (pc : Addr.t) loop_stack frontier interm =
           in
           never_body, [ for_loop ]
         in
-        never_body, body
+        let never_after, after =
+          compile_merge_node st exit_cont loop_stack frontier interm merge_node
+        in
+        never_body || never_after, exit_prefix @ body @ after
 
 (* Compile block. Loops have already been handled. *)
 and compile_block_no_loop st queue (pc : Addr.t) loop_stack frontier interm =

compiler/tests-compiler/gh1007.ml

@@ -156,7 +156,6 @@ let ()  = M.myfun M.x
     {|
     function myfun(x)
      {var x$0=x;
-      a:
       for(;;)
        {if(! x$0)return 0;
         var
@@ -206,6 +205,7 @@ let ()  = M.myfun M.x
              match$1=sort(n2,l2$0),
              tl$0=match$1[2],
              s2=match$1[1],
+             switch$0=0,
              l1=s1,
              l2=s2,
              accu=0;
@@ -216,11 +216,12 @@ let ()  = M.myfun M.x
                   if(0 < caml_int_compare(h1,h2))
                    {var accu$0=[0,h2,accu],l2=t2,accu=accu$0;continue}
                   var accu$1=[0,h1,accu],l1=t1,accu=accu$1;
-                  continue}
-                var _c_=rev_append(l1,accu)}
+                  continue}}
               else
-               var _c_=rev_append(l2,accu);
-              return [0,_c_,tl$0]}},
+               switch$0 = 1;
+              break}
+            var _c_=switch$0?rev_append(l2,accu):rev_append(l1,accu);
+            return [0,_c_,tl$0]},
          sort=
           function(n,l)
            {if(2 === n)
@@ -266,6 +267,7 @@ let ()  = M.myfun M.x
              match$1=rev_sort(n2,l2$0),
              tl$0=match$1[2],
              s2=match$1[1],
+             switch$0=0,
              l1=s1,
              l2=s2,
              accu=0;
@@ -276,19 +278,20 @@ let ()  = M.myfun M.x
                   if(0 < caml_int_compare(h1,h2))
                    {var accu$0=[0,h1,accu],l1=t1,accu=accu$0;continue}
                   var accu$1=[0,h2,accu],l2=t2,accu=accu$1;
-                  continue}
-                var _a_=rev_append(l1,accu)}
+                  continue}}
               else
-               var _a_=rev_append(l2,accu);
-              return [0,_a_,tl$0]}},
+               switch$0 = 1;
+              break}
+            var _a_=switch$0?rev_append(l2,accu):rev_append(l1,accu);
+            return [0,_a_,tl$0]},
          len=0,
          param=l;
         for(;;)
          {if(param)
            {var l$0=param[2],len$0=len + 1 | 0,len=len$0,param=l$0;continue}
-          if(2 <= len)sort(len,l);
-          var x$0=next;
-          continue a}}}
+          break}
+        if(2 <= len)sort(len,l);
+        var x$0=next}}
     //end |}]
 
 let%expect_test _ =
@@ -345,8 +348,9 @@ let ()  = M.run ()
               default:return 1 - (1 - even(1))}};
         even(i);
         var _a_=i + 1 | 0;
-        if(4 === i)return 0;
-        var i=_a_}}
+        if(4 !== i){var i=_a_;continue}
+        break}
+      return 0}
     //end |}]
 
 let%expect_test _ =
@@ -437,10 +441,10 @@ let ()  = M.run ()
         even(i);
         var _e_=i + 1 | 0;
         if(4 !== i){var i=_e_;continue}
-        var
-         _c_=caml_call1(Stdlib_List[9],delayed[1]),
-         _d_=function(f){return caml_call1(f,0)};
-        return caml_call2(Stdlib_List[17],_d_,_c_)}}
+        break}
+      var _c_=caml_call1(Stdlib_List[9],delayed[1]);
+      function _d_(f){return caml_call1(f,0)}
+      return caml_call2(Stdlib_List[17],_d_,_c_)}
     //end |}]
 
 let%expect_test _ =
@@ -504,7 +508,6 @@ let ()  = M.run ()
     {|
     function run(param)
      {var i=0;
-      a:
       for(;;)
        {var
          closures=
@@ -547,10 +550,11 @@ let ()  = M.run ()
         for(;;)
          {if(759635106 > param$0[1])
            {var f=param$0[2],param$0=caml_call1(f,0);continue}
-          var _g_=i + 1 | 0;
-          if(4 !== i){var i=_g_;continue a}
-          var
-           _e_=caml_call1(Stdlib_List[9],delayed[1]),
-           _f_=function(f){return caml_call1(f,0)};
-          return caml_call2(Stdlib_List[17],_f_,_e_)}}}
+          break}
+        var _g_=i + 1 | 0;
+        if(4 !== i){var i=_g_;continue}
+        break}
+      var _e_=caml_call1(Stdlib_List[9],delayed[1]);
+      function _f_(f){return caml_call1(f,0)}
+      return caml_call2(Stdlib_List[17],_f_,_e_)}
     //end |}]

compiler/tests-compiler/gh1320.ml

@@ -58,6 +58,7 @@ let () = myfun ()
          _b_=g(i);
         caml_call2(Stdlib_Printf[3],_a_,_b_);
         var _c_=i + 1 | 0;
-        if(4 === i)return 0;
-        var i=_c_}}
+        if(4 !== i){var i=_c_;continue}
+        break}
+      return 0}
     //end |}]