Eliminate dead `ICatch` handlers (#2321)

Changes

@@ -54,6 +54,9 @@ Working version
   each function in a separate named text section on supported targets.
   (Greta Yorsh, review by Pierre Chambart)
 
+- #2321: Eliminate dead ICatch handlers
+  (Greta Yorsh, review by Pierre Chambart and Vincent Laviron)
+
 ### Runtime system:
 
 - #8619: Ensure Gc.minor_words remains accurate after a GC.

asmcomp/deadcode.ml

@@ -18,8 +18,23 @@
 
 open Mach
 
-(* [deadcode i] returns a pair of an optimized instruction [i']
-   and a set of registers live "before" instruction [i]. *)
+module Int = Numbers.Int
+
+type d = {
+  i : instruction;   (* optimized instruction *)
+  regs : Reg.Set.t;  (* a set of registers live "before" instruction [i] *)
+  exits : Int.Set.t;  (* indexes of Iexit instructions "live before" [i] *)
+}
+
+let append a b =
+  let rec append a b =
+    match a.desc with
+    | Iend -> b
+    | _ -> { a with next = append a.next b }
+  in
+  match b.desc with
+  | Iend -> a
+  | _ -> append a b
 
 let rec deadcode i =
   let arg =
@@ -30,48 +45,104 @@ let rec deadcode i =
   in
   match i.desc with
   | Iend | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) | Iraise _ ->
-      (i, Reg.add_set_array i.live arg)
+      let regs = Reg.add_set_array i.live arg in
+      { i; regs; exits = Int.Set.empty; }
   | Iop op ->
-      let (s, before) = deadcode i.next in
+      let s = deadcode i.next in
       if Proc.op_is_pure op                     (* no side effects *)
-      && Reg.disjoint_set_array before i.res    (* results are not used after *)
+      && Reg.disjoint_set_array s.regs i.res   (* results are not used after *)
       && not (Proc.regs_are_volatile arg)      (* no stack-like hard reg *)
       && not (Proc.regs_are_volatile i.res)    (*            is involved *)
       then begin
         assert (Array.length i.res > 0);  (* sanity check *)
-        (s, before)
+        s
       end else begin
-        ({i with next = s}, Reg.add_set_array i.live arg)
+        { i = {i with next = s.i};
+          regs = Reg.add_set_array i.live arg;
+          exits = s.exits;
+        }
       end
   | Iifthenelse(test, ifso, ifnot) ->
-      let (ifso', _) = deadcode ifso in
-      let (ifnot', _) = deadcode ifnot in
-      let (s, _) = deadcode i.next in
-      ({i with desc = Iifthenelse(test, ifso', ifnot'); next = s},
-       Reg.add_set_array i.live arg)
+      let ifso' = deadcode ifso in
+      let ifnot' = deadcode ifnot in
+      let s = deadcode i.next in
+      { i = {i with desc = Iifthenelse(test, ifso'.i, ifnot'.i); next = s.i};
+        regs = Reg.add_set_array i.live arg;
+        exits = Int.Set.union s.exits
+                  (Int.Set.union ifso'.exits ifnot'.exits);
+      }
   | Iswitch(index, cases) ->
-      let cases' = Array.map (fun c -> fst (deadcode c)) cases in
-      let (s, _) = deadcode i.next in
-      ({i with desc = Iswitch(index, cases'); next = s},
-       Reg.add_set_array i.live arg)
+      let dc = Array.map deadcode cases in
+      let cases' = Array.map (fun c -> c.i) dc in
+      let s = deadcode i.next in
+      { i = {i with desc = Iswitch(index, cases'); next = s.i};
+        regs = Reg.add_set_array i.live arg;
+        exits = Array.fold_left
+                  (fun acc c -> Int.Set.union acc c.exits) s.exits dc;
+      }
   | Icatch(rec_flag, handlers, body) ->
-      let (body', _) = deadcode body in
-      let handlers' =
-        List.map (fun (nfail, handler) ->
-            let (handler', _) = deadcode handler in
-            nfail, handler')
-          handlers
-      in
-      let (s, _) = deadcode i.next in
-      ({i with desc = Icatch(rec_flag, handlers', body'); next = s}, i.live)
-  | Iexit _nfail ->
-      (i, i.live)
+    let body' = deadcode body in
+    let s = deadcode i.next in
+    let handlers' = Int.Map.map deadcode (Int.Map.of_list handlers) in
+    (* Previous passes guarantee that indexes of handlers are unique
+       across the entire function and Iexit instructions refer
+       to the correctly scoped handlers.
+       We do not rely on it here, for safety. *)
+    let rec add_live nfail (live_exits, used_handlers) =
+      if Int.Set.mem nfail live_exits then
+        (live_exits, used_handlers)
+      else
+        let live_exits = Int.Set.add nfail live_exits in
+        match Int.Map.find_opt nfail handlers' with
+        | None -> (live_exits, used_handlers)
+        | Some handler ->
+          let used_handlers = (nfail, handler) :: used_handlers in
+          match rec_flag with
+          | Cmm.Nonrecursive -> (live_exits, used_handlers)
+          | Cmm.Recursive ->
+            Int.Set.fold add_live handler.exits (live_exits, used_handlers)
+    in
+    let live_exits, used_handlers =
+      Int.Set.fold add_live body'.exits (Int.Set.empty, [])
+    in
+    (* Remove exits that are going out of scope. *)
+    let used_handler_indexes = Int.Set.of_list (List.map fst used_handlers) in
+    let live_exits = Int.Set.diff live_exits used_handler_indexes in
+    (* For non-recursive catch, live exits referenced in handlers are free. *)
+    let live_exits =
+      match rec_flag with
+      | Cmm.Recursive -> live_exits
+      | Cmm.Nonrecursive ->
+        List.fold_left (fun exits (_,h) -> Int.Set.union h.exits exits)
+          live_exits
+          used_handlers
+    in
+    let exits = Int.Set.union s.exits live_exits in
+    begin match used_handlers with
+    | [] -> (* Simplify catch without handlers *)
+      { i = append body'.i s.i;
+        regs = body'.regs;
+        exits;
+      }
+    | _ ->
+      let handlers = List.map (fun (n,h) -> (n,h.i)) used_handlers in
+      { i = { i with desc = Icatch(rec_flag, handlers, body'.i); next = s.i };
+        regs = i.live;
+        exits;
+      }
+    end
+  | Iexit nfail ->
+      { i;  regs = i.live; exits = Int.Set.singleton nfail; }
   | Itrywith(body, handler) ->
-      let (body', _) = deadcode body in
-      let (handler', _) = deadcode handler in
-      let (s, _) = deadcode i.next in
-      ({i with desc = Itrywith(body', handler'); next = s}, i.live)
+      let body' = deadcode body in
+      let handler' = deadcode handler in
+      let s = deadcode i.next in
+      { i = {i with desc = Itrywith(body'.i, handler'.i); next = s.i};
+        regs = i.live;
+        exits = Int.Set.union s.exits
+                  (Int.Set.union body'.exits handler'.exits);
+      }
 
 let fundecl f =
-  let (new_body, _) = deadcode f.fun_body in
-  {f with fun_body = new_body}
+  let new_body = deadcode f.fun_body in
+  {f with fun_body = new_body.i}

ocamltest/ocaml_actions.ml

@@ -686,6 +686,7 @@ let finalise_codegen_msvc ocamlsrcdir test_basename log env =
 let run_codegen log env =
   let ocamlsrcdir = Ocaml_directories.srcdir () in
   let testfile = Actions_helpers.testfile env in
+  let testfile_basename = Filename.chop_extension testfile in
   let what = Printf.sprintf "Running codegen on %s" testfile in
   Printf.fprintf log "%s\n%!" what;
   let test_build_directory =
@@ -699,9 +700,13 @@ let run_codegen log env =
       compiler_output
       env
   in
+  let output_file = Filename.make_filename testfile_basename "output" in
+  let output = Filename.make_path [test_build_directory; output_file] in
+  let env = Environments.add Builtin_variables.output output env in
   let commandline =
   [
     Ocaml_commands.ocamlrun_codegen ocamlsrcdir;
+    flags env;
     "-S " ^ testfile
   ] in
   let expected_exit_status = 0 in
@@ -714,7 +719,6 @@ let run_codegen log env =
       log env commandline in
   if exit_status=expected_exit_status
   then begin
-    let testfile_basename = Filename.chop_extension testfile in
     let finalise =
        if Ocamltest_config.ccomptype="msvc"
       then finalise_codegen_msvc

testsuite/tests/asmgen/catch-rec-deadhandler.cmm

@@ -0,0 +1,17 @@
+(* TEST
+flags = "-dlive"
+files = "main.c"
+arguments = "-DUNIT_INT -DFUN=catch_rec_deadhandler main.c"
+* asmgen
+** run
+*** check-program-output
+*)
+
+(function "catch_rec_deadhandler" ()
+  (let x
+    (catch
+      (exit one)
+     with (one) 1
+     and (two) (exit three)
+     and (three) 3)
+    x))

testsuite/tests/asmgen/catch-rec-deadhandler.reference

@@ -0,0 +1,6 @@
+  catch rec
+    exit(1)
+  with(1)
+  catch rec
+    exit(1)
+  with(1)

testsuite/tests/asmgen/catch-rec-deadhandler.run

@@ -0,0 +1,5 @@
+#!/bin/sh
+
+exec > "${output}" 2>&1
+
+grep -E "catch |with\(|and\(|exit\(" "${compiler_output}"

testsuite/tests/asmgen/ocamltests

@@ -4,6 +4,7 @@ catch-try.cmm
 catch-float.cmm
 catch-multiple.cmm
 catch-try-float.cmm
+catch-rec-deadhandler.cmm
 checkbound.cmm
 even-odd-spill.cmm
 even-odd-spill-float.cmm

testsuite/tests/asmgen/quicksort.cmm

@@ -27,16 +27,16 @@ arguments = "-DSORT -DFUN=quicksort main.c"
         (while (< i j)
           (catch
               (while 1
-                (if (>= i hi) exit [])
-                (if (> (addraref a i) pivot) exit [])
+                (if (>= i hi) (exit n25) [])
+                (if (> (addraref a i) pivot) (exit n25) [])
                 (assign i (+ i 1)))
-           with [])
+           with (n25) [])
           (catch
               (while 1
-                (if (<= j lo) exit [])
-                (if (< (addraref a j) pivot) exit [])
+                (if (<= j lo) (exit n35) [])
+                (if (< (addraref a j) pivot) (exit n35) [])
                 (assign j (- j 1)))
-           with [])
+           with (n35) [])
           (if (< i j)
               (let temp (addraref a i)
                    (addraset a i (addraref a j))

testsuite/tests/asmgen/quicksort2.cmm

@@ -30,16 +30,16 @@ arguments = "-DSORT -DFUN=quicksort main.c"
         (while (< i j)
           (catch
             (while 1
-              (if (>= i hi) exit [])
-              (if (> (app cmp (intaref a i) pivot int) 0) exit [])
+              (if (>= i hi) (exit n25) [])
+              (if (> (app cmp (intaref a i) pivot int) 0) (exit n25) [])
               (assign i (+ i 1)))
-            with [])
+            with (n25) [])
           (catch
             (while 1
-              (if (<= j lo) exit [])
-              (if (< (app cmp (intaref a j) pivot int) 0) exit [])
+              (if (<= j lo) (exit n35) [])
+              (if (< (app cmp (intaref a j) pivot int) 0) (exit n35) [])
               (assign j (- j 1)))
-           with [])
+           with (n35) [])
           (if (< i j)
               (let temp (intaref a i)
                    (intaset a i (intaref a j))

testsuite/tests/asmgen/tagged-quicksort.cmm

@@ -27,16 +27,16 @@ arguments = "-DSORT -DFUN=quicksort main.c"
         (while (< i j)
           (catch
               (while 1
-                (if (>= i hi) exit [])
-                (if (> (addraref a (>>s i 1)) pivot) exit [])
+                (if (>= i hi) (exit n25) [])
+                (if (> (addraref a (>>s i 1)) pivot) (exit n25) [])
                 (assign i (+ i 2)))
-           with [])
+           with (n25) [])
           (catch
               (while 1
-                (if (<= j lo) exit [])
-                (if (< (addraref a (>>s j 1)) pivot) exit [])
+                (if (<= j lo) (exit n35) [])
+                (if (< (addraref a (>>s j 1)) pivot) (exit n35) [])
                 (assign j (- j 2)))
-           with [])
+           with (n35) [])
           (if (< i j)
               (let temp (addraref a (>>s i 1))
                    (addraset a (>>s i 1) (addraref a (>>s j 1)))

testsuite/tools/parsecmm.mly

@@ -222,15 +222,19 @@ expr:
       { Cifthenelse($3, debuginfo (), $4, debuginfo (), $5, debuginfo ()) }
   | LPAREN SWITCH INTCONST expr caselist RPAREN { make_switch $3 $4 $5 }
   | LPAREN WHILE expr sequence RPAREN
-      { let body =
+      {
+        let lbl0 = Lambda.next_raise_count () in
+        let lbl1 = Lambda.next_raise_count () in
+        let body =
           match $3 with
             Cconst_int (x, _) when x <> 0 -> $4
-          | _ -> Cifthenelse($3, debuginfo (), $4, debuginfo (), (Cexit(0,[])),
+          | _ -> Cifthenelse($3, debuginfo (), $4, debuginfo (),
+                             (Cexit(lbl0,[])),
                              debuginfo ()) in
-        Ccatch(Nonrecursive, [0, [],
+        Ccatch(Nonrecursive, [lbl0, [], Ctuple [], debuginfo ()],
           Ccatch(Recursive,
-            [1, [], Csequence(body, Cexit(1, [])), debuginfo ()],
-            Cexit(1, [])), debuginfo ()], Ctuple []) }
+            [lbl1, [], Csequence(body, Cexit(lbl1, [])), debuginfo ()],
+            Cexit(lbl1, []))) }
   | LPAREN EXIT IDENT exprlist RPAREN
     { Cexit(find_label $3, List.rev $4) }
   | LPAREN CATCH sequence WITH catch_handlers RPAREN