Compiler: improve dominator tree for try-catch

ocsigen · Aug 2, 2023 · bfd2c75 · bfd2c75
1 parent 78fdbc7
commit bfd2c75
Show file tree

Hide file tree

Showing 3 changed files with 453 additions and 530 deletions.
diff --git a/compiler/lib/structure.ml b/compiler/lib/structure.ml
@@ -17,12 +17,6 @@ let reverse_graph g =
     g;
   g'
 
-let rec leave_try_body blocks pc =
-  match Addr.Map.find pc blocks with
-  | { body = []; branch = (Return _ | Stop), _; _ } -> false
-  | { body = []; branch = Branch (pc', _), _; _ } -> leave_try_body blocks pc'
-  | _ -> true
-
 type graph = (Addr.t, Addr.Set.t) Hashtbl.t
 
 type t =
@@ -44,10 +38,30 @@ let is_backward g pc pc' = Hashtbl.find g.block_order pc >= Hashtbl.find g.block
 
 let is_forward g pc pc' = Hashtbl.find g.block_order pc < Hashtbl.find g.block_order pc'
 
+(* pc has at least two forward edges moving into it *)
+let is_merge_node' block_order preds pc =
+  let s = try Hashtbl.find preds pc with Not_found -> Addr.Set.empty in
+  let o = Hashtbl.find block_order pc in
+  let n =
+    Addr.Set.fold (fun pc' n -> if Hashtbl.find block_order pc' < o then n + 1 else n) s 0
+  in
+  n > 1
+
+let rec leave_try_body block_order preds blocks pc =
+  if is_merge_node' block_order preds pc
+  then false
+  else
+    match Addr.Map.find pc blocks with
+    | { body = []; branch = (Return _ | Stop), _; _ } -> false
+    | { body = []; branch = Branch (pc', _), _; _ } ->
+        leave_try_body block_order preds blocks pc'
+    | _ -> true
+
 let build_graph blocks pc =
   let succs = Hashtbl.create 16 in
   let l = ref [] in
   let visited = Hashtbl.create 16 in
+  let poptraps = ref [] in
   let rec traverse ~englobing_exn_handlers pc =
     if not (Hashtbl.mem visited pc)
     then (
@@ -65,13 +79,7 @@ let build_graph blocks pc =
                 match englobing_exn_handlers with
                 | [] -> assert false
                 | enter_pc :: rem ->
-                    if leave_try_body 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));
+                    poptraps := (enter_pc, leave_pc) :: !poptraps;
                     rem)
             | _ -> englobing_exn_handlers
           in
@@ -83,6 +91,12 @@ let build_graph blocks pc =
   let block_order = Hashtbl.create 16 in
   List.iteri !l ~f:(fun i pc -> Hashtbl.add block_order pc i);
   let preds = reverse_graph succs in
+  List.iter !poptraps ~f:(fun (enter_pc, leave_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)));
+  let preds = reverse_graph succs in
   { succs; preds; reverse_post_order = !l; block_order }
 
 let dominator_tree g =
@@ -119,16 +133,7 @@ let dominator_tree g =
   reverse_tree dom
 
 (* pc has at least two forward edges moving into it *)
-let is_merge_node g pc =
-  let s = try Hashtbl.find g.preds pc with Not_found -> Addr.Set.empty in
-  let o = Hashtbl.find g.block_order pc in
-  let n =
-    Addr.Set.fold
-      (fun pc' n -> if Hashtbl.find g.block_order pc' < o then n + 1 else n)
-      s
-      0
-  in
-  n > 1
+let is_merge_node g pc = is_merge_node' g.block_order g.preds pc
 
 let is_loop_header g pc =
   let s = try Hashtbl.find g.preds pc with Not_found -> Addr.Set.empty in

diff --git a/compiler/tests-compiler/exceptions.ml b/compiler/tests-compiler/exceptions.ml
@@ -33,15 +33,11 @@ let prevent_inline = some_name
   [%expect
     {|
     function some_name(param){
-     a:
-     {
-      try{
-       try{throw caml_maybe_attach_backtrace(Stdlib[8], 1);}
-       catch(x$0){var x = caml_wrap_exception(x$0);}
-      }
-      catch(i$1){var i = caml_wrap_exception(i$1), i$0 = i; break a;}
-      var i$0 = x;
+     try{
+      try{throw caml_maybe_attach_backtrace(Stdlib[8], 1);}
+      catch(x$0){var x = caml_wrap_exception(x$0), i$0 = x;}
      }
+     catch(i$1){var i = caml_wrap_exception(i$1), i$0 = i;}
      throw caml_maybe_attach_backtrace(i$0, 1);
     }
     //end |}];