From 752ddea916482b8721f0438417dd972f3b42aede Mon Sep 17 00:00:00 2001
From: sneeker <s@cpl0.zip>
Date: Fri, 15 Jul 2022 04:18:43 +0000
Subject: [PATCH] feat(sched): cancel in-flight actions when a build fails

Only new spawns were held back after a failure, so every action already running
was allowed to finish even though its output would be discarded. The scheduler
now sends SIGTERM to the remaining children on the first failure, and reports
them separately rather than counting a process it killed as a failure of its
own. Partial outputs are removed and their cache entries dropped, so the next
run starts clean.

Under -k the existing behaviour is kept, since keeping going is the point.

On a graph with three six-second generators alongside one translation unit that
fails immediately, -j4 now returns in 0.12 s rather than 6.03 s.
---
 bin/meowc.ml |  8 +++++---
 lib/sched.ml | 42 +++++++++++++++++++++++++++++++-----------
 2 files changed, 36 insertions(+), 14 deletions(-)

diff --git a/bin/meowc.ml b/bin/meowc.ml
index 065178c..23925cc 100644
--- a/bin/meowc.ml
+++ b/bin/meowc.ml
@@ -205,7 +205,7 @@ let execute p ~names =
         end)
       order;
     Printf.printf "\n  %s\n" (Style.dim (Printf.sprintf "%d actions, nothing run" !n));
-    (b, { Sched.built = 0; cached = 0; failed = 0 })
+    (b, { Sched.built = 0; cached = 0; failed = 0; aborted = 0 })
   end
   else begin
     let cache = Cache.load (Filename.concat p.tc.builddir ".meowc-cache") in
@@ -223,12 +223,14 @@ let execute p ~names =
 let summarise (r : Sched.result) elapsed =
   if not fl.quiet && not fl.dry then begin
     let text =
-      if r.failed > 0 then Style.red (Style.plural r.failed "action" ^ " failed")
+      if r.failed > 0 then
+        Style.red (Style.plural r.failed "action" ^ " failed")
+        ^ (if r.aborted > 0 then Style.dim (Printf.sprintf ", %d cancelled" r.aborted) else "")
       else if r.built = 0 then Style.dim "nothing to do"
       else Printf.sprintf "%d built%s" r.built (Style.dim (Printf.sprintf ", %d cached" r.cached))
     in
     Printf.printf "%s  %s%s\n"
-      (if r.built + r.failed = 0 then "" else "\n")
+      (if r.built + r.failed + r.aborted = 0 then "" else "\n")
       (Style.pad 48 text) (Style.dim (duration elapsed))
   end;
   if r.failed > 0 then exit 1
diff --git a/lib/sched.ml b/lib/sched.ml
index 16e995b..95cf191 100644
--- a/lib/sched.ml
+++ b/lib/sched.ml
@@ -1,4 +1,4 @@
-type result = { built : int; cached : int; failed : int }
+type result = { built : int; cached : int; failed : int; aborted : int }
 
 type state = Blocked | Ready | Running | Done | Failed
 
@@ -32,7 +32,8 @@ let run g ~selected ~jobs ~cache ~verbose ~keep_going ~on_start ~on_done =
   let ready = Queue.create () in
   Array.iter (fun (v : Graph.node) -> if wanted v.id && pending.(v.id) = 0 then Queue.add v.id ready) nodes;
   let running = Hashtbl.create 8 in
-  let built = ref 0 and cached = ref 0 and failed = ref 0 in
+  let cancelled = Hashtbl.create 8 in
+  let built = ref 0 and cached = ref 0 and failed = ref 0 and aborted_count = ref 0 in
   let stopping () = !failed > 0 && not keep_going in
   let release i =
     List.iter
@@ -66,12 +67,27 @@ let run g ~selected ~jobs ~cache ~verbose ~keep_going ~on_start ~on_done =
     on_start v;
     Hashtbl.replace running pid (v, tmp)
   in
+  let cancel_running () =
+    Hashtbl.iter
+      (fun pid _ ->
+        Hashtbl.replace cancelled pid ();
+        try Unix.kill pid Sys.sigterm with Unix.Unix_error _ -> ())
+      running
+  in
+  let discard (v : Graph.node) =
+    List.iter Cache.forget v.outs;
+    Cache.drop cache (List.hd v.outs);
+    List.iter (fun o -> try Sys.remove o with Sys_error _ -> ()) v.outs;
+    skip v.id
+  in
   let reap () =
     let pid, status = Unix.wait () in
     match Hashtbl.find_opt running pid with
     | None -> ()
     | Some (v, tmp) ->
         Hashtbl.remove running pid;
+        let aborted = Hashtbl.mem cancelled pid in
+        Hashtbl.remove cancelled pid;
         let ok = status = Unix.WEXITED 0 in
         let log = try Fs.read tmp with Sys_error _ -> "" in
         (try Sys.remove tmp with Sys_error _ -> ());
@@ -81,17 +97,21 @@ let run g ~selected ~jobs ~cache ~verbose ~keep_going ~on_start ~on_done =
           List.iter Cache.forget v.outs;
           (match v.depfile with Some d -> Cache.forget d | None -> ());
           Cache.put cache (List.hd v.outs) (key_of v);
-          release v.id
+          release v.id;
+          on_done ~ok ~log v;
+          if verbose then print_endline ("      " ^ Style.dim (Exec.show v.cmd))
+        end
+        else if aborted then begin
+          incr aborted_count;
+          discard v
         end
         else begin
           incr failed;
-          List.iter Cache.forget v.outs;
-          Cache.drop cache (List.hd v.outs);
-          List.iter (fun o -> try Sys.remove o with Sys_error _ -> ()) v.outs;
-          skip v.id
-        end;
-        on_done ~ok ~log v;
-        if verbose then print_endline ("      " ^ Style.dim (Exec.show v.cmd))
+          discard v;
+          on_done ~ok ~log v;
+          if verbose then print_endline ("      " ^ Style.dim (Exec.show v.cmd));
+          if not keep_going then cancel_running ()
+        end
   in
   while (not (Queue.is_empty ready) && not (stopping ())) || Hashtbl.length running > 0 do
     while (not (Queue.is_empty ready)) && Hashtbl.length running < jobs && not (stopping ()) do
@@ -107,4 +127,4 @@ let run g ~selected ~jobs ~cache ~verbose ~keep_going ~on_start ~on_done =
     if Hashtbl.length running > 0 then reap ()
     else if Queue.is_empty ready then ()
   done;
-  { built = !built; cached = !cached; failed = !failed }
+  { built = !built; cached = !cached; failed = !failed; aborted = !aborted_count }