jobs: Introduce stop_all function to stop job submission on error.

diff --git a/src/jobs.ml b/src/jobs.ml
index f9ead52..5b1067f 100644 (file)
--- a/src/jobs.ml
+++ b/src/jobs.ml
@@ -29,6 +29,7 @@ module type Jobs = sig
   val new_group : unit -> group
   val start : group -> key -> (unit -> unit) -> unit
   val wait : group -> unit
+  val stop_all : unit -> unit
 end
 
 module Make (K : Key) = struct
@@ -79,12 +80,17 @@ module Make (K : Key) = struct
    *)
   let ready = ref 1
 
+  (* If stop_all is called, this is set to true and we stop
+   * running new jobs.
+   *)
+  let stop = ref false
+
   (* The worker thread. *)
   let rec worker _ =
     let id = Thread.id (Thread.self ()) in
     Mutex.lock lock;
     incr ready;
-    while !ready <= Cmdline.nr_jobs do
+    while not !stop && !ready <= Cmdline.nr_jobs do
       (* See if there's any queue with a job which is ready to run. *)
       Cmdline.debug "thread %d: checking for a runnable queue" id;
       match get_runnable_queue () with
@@ -185,4 +191,13 @@ module Make (K : Key) = struct
    *)
   and all_done group = List.for_all (fun { state } -> state = Done) !group
 
+  let stop_all () =
+    Mutex.lock lock;
+    (* All threads will exit after running jobs if this is set. *)
+    stop := true;
+    while !ready > 1 do
+      Condition.wait idle lock;
+    done;
+    Mutex.unlock lock
+
 end

diff --git a/src/jobs.mli b/src/jobs.mli
index 697263d..afafbbd 100644 (file)
--- a/src/jobs.mli
+++ b/src/jobs.mli
@@ -61,6 +61,11 @@ module type Jobs = sig
 
   val wait : group -> unit
   (** [wait group] waits for all of the jobs in the group to finish. *)
+
+  val stop_all : unit -> unit
+  (** This is used when goals exits with an error.  All jobs which
+      are waiting to run are deleted, and we wait for all running
+      jobs to finish. *)
 end
 
 module Make (K : Key) : Jobs with type key = K.t

diff --git a/src/main.ml b/src/main.ml
index 63dac2b..62ea68a 100644 (file)
--- a/src/main.ml
+++ b/src/main.ml
@@ -81,4 +81,6 @@ let () =
   try main ()
   with
     Failure msg | Sys_error msg ->
-      prerr_endline ("error: " ^ msg); exit 1
+      Run.stop_all ();
+      prerr_endline ("*** error: " ^ msg);
+      exit 1

diff --git a/src/run.ml b/src/run.ml
index 9a15775..c3aa11e 100644 (file)
--- a/src/run.ml
+++ b/src/run.ml
@@ -36,6 +36,8 @@ module Jobs = Jobs.Make (
   end
 )
 
+let stop_all = Jobs.stop_all
+
 (* Starts the target expressions running and waits for them to complete. *)
 let rec run_targets_to_completion env exprs =
   let group = Jobs.new_group () in

diff --git a/src/run.mli b/src/run.mli
index 6281242..4251235 100644 (file)
--- a/src/run.mli
+++ b/src/run.mli
@@ -22,3 +22,7 @@ val run_targets_to_completion : Ast.env -> Ast.expr list -> unit
     parallel) until they are complete or we reach an error.  The
     expressions are either a list of dependencies and/or a list of
     initial targets. *)
+
+val stop_all : unit -> unit
+(** Wait until all running jobs finish, and don't start any new ones.
+    See [Jobs.stop_all]. *)