type 'a next = Job of 'a * (unit -> unit) | Complete | Not_ready
-type 'a retire = 'a -> unit
-
-type 'a to_string = 'a -> string
-
-let run next_job retire_job string_of_job =
+let run next_job retire_job fail_job string_of_job =
(* Number of running threads <= Cmdline.nr_jobs. *)
let running = ref 0 in
let lock = Mutex.create () and cond = Condition.create () in
(* If a job throws an exception it is saved here. *)
- let last_exn = ref None in
+ let last_exn = ref [] in
(* This is the background thread which runs each job. *)
let runner (job, f) =
Mutex.lock lock;
(match exn with
| None -> retire_job job
- | Some exn -> last_exn := Some exn
+ | Some exn ->
+ last_exn := exn :: !last_exn;
+ fail_job job
);
decr running;
Condition.signal cond;
in
let rec loop () =
- if !last_exn = None then (
+ let continue = !last_exn = [] || Cmdline.keep_going () in
+ if continue then (
match next_job () with
- | Complete ->
- if !running > 0 then (
- Cmdline.debug "%d/%d threads running, waiting for completion"
- !running (Cmdline.nr_jobs ());
- Condition.wait cond lock;
- loop ()
- )
+ | Complete -> ()
| Not_ready ->
assert (!running > 0);
Cmdline.debug "%d/%d threads running, waiting for dependencies"
in
Mutex.lock lock;
loop ();
- let exn = !last_exn in
+
+ (* Wait for all jobs to complete. *)
+ while !running > 0 do
+ Cmdline.debug "%d/%d threads running, waiting for completion"
+ !running (Cmdline.nr_jobs ());
+ Condition.wait cond lock
+ done;
+
+ let exns = !last_exn in
Mutex.unlock lock;
- (* Re-raise the saved exception from the job which failed. *)
- match exn with
- | None -> ()
- | Some exn -> raise exn
+ (* Re-raise the saved exception(s) from the job(s) which failed. *)
+ match exns with
+ | [] -> ()
+ | [exn] -> raise exn
+ | exns ->
+ (* Combine the multiple exceptions into a single Failure exn. *)
+ let exns = List.rev exns in
+ let exn_to_string = function
+ | Failure s -> s
+ | exn -> Printexc.to_string exn in
+ let exns = List.map exn_to_string exns in
+ let exns = String.concat "\n" exns in
+ raise (Failure exns)