Compiler: exit loop early

CHANGES.md

@@ -3,6 +3,7 @@
 ## Features/Changes
 * Compiler: global dead code elimination (Micah Cantor, #1503)
 * Compiler: change control-flow compilation strategy (#1496)
+* Compiler: loop no longer absorb the whole continuation
 * Compiler: Dead code elimination of unused references (#2076)
 * Compiler: reduce memory consumption (#1516)
 * Compiler: support for es6 import and export construct

compiler/lib/generate.ml

@@ -20,17 +20,12 @@
 
 (*XXX
   Patterns:
-  => loops should avoid absorbing the whole continuation...
-     (detect when the continuation does not loop anymore and close
-      the loop at this point)
   => should have special code for switches that include the preceding
      if statement when possible
   => if e1 then {if e2 then P else Q} else {if e3 then P else Q}
   => if e then return e1; return e2
   => if e then var x = e1; else var x = e2;
   => while (true) {.... if (e) continue; break; }
-
-  - CLEAN UP!!!
 *)
 
 open! Stdlib

compiler/lib/structure.ml

@@ -95,8 +95,14 @@ let build_graph blocks pc =
       if leave_try_body block_order preds blocks leave_pc
       then (
         (* Add an edge to limit the [try] body *)
-        Hashtbl.add succs enter_pc (Addr.Set.add leave_pc (Hashtbl.find succs enter_pc));
-        Hashtbl.add preds leave_pc (Addr.Set.add enter_pc (Hashtbl.find preds leave_pc))));
+        Hashtbl.replace
+          succs
+          enter_pc
+          (Addr.Set.add leave_pc (Hashtbl.find succs enter_pc));
+        Hashtbl.replace
+          preds
+          leave_pc
+          (Addr.Set.add enter_pc (Hashtbl.find preds leave_pc))));
   { succs; preds; reverse_post_order = !l; block_order }
 
 let dominator_tree g =
@@ -166,3 +172,79 @@ let dominance_frontier g idom =
     g.preds;
   frontiers
 *)
+
+(* Compute a map from each block to the set of loops it belongs to *)
+let mark_loops g =
+  let in_loop = Hashtbl.create 16 in
+  Hashtbl.iter
+    (fun pc preds ->
+      let rec mark_loop pc' =
+        if not (Addr.Set.mem pc (get_edges in_loop pc'))
+        then (
+          add_edge in_loop pc' pc;
+          if pc' <> pc then Addr.Set.iter mark_loop (Hashtbl.find g.preds pc'))
+      in
+      Addr.Set.iter (fun pc' -> if is_backward g pc' pc then mark_loop pc') preds)
+    g.preds;
+  in_loop
+
+let rec measure blocks g pc limit =
+  if is_loop_header g pc
+  then -1
+  else
+    let b = Addr.Map.find pc blocks in
+    let limit = limit - List.length b.body in
+    if limit < 0
+    then limit
+    else
+      Addr.Set.fold
+        (fun pc limit -> if limit < 0 then limit else measure blocks g pc limit)
+        (get_edges g.succs pc)
+        limit
+
+let is_small blocks g pc = measure blocks g pc 20 >= 0
+
+let shrink_loops blocks ({ succs; preds; reverse_post_order; _ } as g) =
+  let add_edge pred succ =
+    Hashtbl.replace succs pred (Addr.Set.add succ (Hashtbl.find succs pred));
+    Hashtbl.replace preds succ (Addr.Set.add pred (Hashtbl.find preds succ))
+  in
+  let in_loop = mark_loops g in
+  let dom = dominator_tree g in
+  let root = List.hd reverse_post_order in
+  let rec traverse ignored pc =
+    let succs = get_edges dom pc in
+    let loops = get_edges in_loop pc in
+    let block = Addr.Map.find pc blocks in
+    Addr.Set.iter
+      (fun pc' ->
+        (* Whatever is in the scope of an exception handler should not be
+           moved outside *)
+        let ignored =
+          match fst block.branch with
+          | Pushtrap ((body_pc, _), _, _, _) when pc' = body_pc ->
+              Addr.Set.union ignored loops
+          | _ -> ignored
+        in
+        let loops' = get_edges in_loop pc' in
+        let left_loops = Addr.Set.diff (Addr.Set.diff loops loops') ignored in
+        (* If we leave a loop, we add an edge from predecessors of
+           the loop header to the current block, so that it is
+           considered outside of the loop. *)
+        if not (Addr.Set.is_empty left_loops || is_small blocks g pc')
+        then
+          Addr.Set.iter
+            (fun pc0 ->
+              Addr.Set.iter
+                (fun pc -> if is_forward g pc pc0 then add_edge pc pc')
+                (get_edges g.preds pc0))
+            left_loops;
+        traverse ignored pc')
+      succs
+  in
+  traverse Addr.Set.empty root
+
+let build_graph blocks pc =
+  let g = build_graph blocks pc in
+  shrink_loops blocks g;
+  g

compiler/tests-compiler/gh1007.ml

@@ -319,9 +319,11 @@ let ()  = M.myfun M.x
        len = 0,
        param = l;
       for(;;){
-       if(! param){if(2 <= len) sort(len, l); var x$0 = next; break;}
+       if(! param) break;
        var l$0 = param[2], len$0 = len + 1 | 0, len = len$0, param = l$0;
       }
+      if(2 <= len) sort(len, l);
+      var x$0 = next;
      }
     }
     //end |}]
@@ -625,14 +627,15 @@ let ()  = M.run ()
        even = closures$0[1],
        param$0 = even(i);
       for(;;){
-       if(759635106 <= param$0[1]){
-        var _g_ = i + 1 | 0;
-        if(4 !== i){var i = _g_; break;}
-        var _f_ = caml_call1(list_rev, delayed[1]);
-        return caml_call2(list_iter, function(f){return caml_call1(f, 0);}, _f_);
-       }
+       if(759635106 <= param$0[1]) break;
        var f = param$0[2], param$0 = f(0);
       }
+      var _g_ = i + 1 | 0;
+      if(4 === i){
+       var _f_ = caml_call1(list_rev, delayed[1]);
+       return caml_call2(list_iter, function(f){return caml_call1(f, 0);}, _f_);
+      }
+      var i = _g_;
      }
     }
     //end |}]