1 (* Goals parallel jobs.
2 * Copyright (C) 2020 Richard W.M. Jones
3 * Copyright (C) 2020 Red Hat Inc.
5 * This program is free software; you can redistribute it and/or modify
6 * it under the terms of the GNU General Public License as published by
7 * the Free Software Foundation; either version 2 of the License, or
8 * (at your option) any later version.
10 * This program is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
15 * You should have received a copy of the GNU General Public License along
16 * with this program; if not, write to the Free Software Foundation, Inc.,
17 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
22 type 'a next = Job of 'a * (unit -> unit) | Complete | Not_ready
24 let run next_job retire_job fail_job string_of_job =
25 (* Number of running threads <= Cmdline.nr_jobs. *)
26 let running = ref 0 in
28 (* Lock and condition for when a thread exits. *)
29 let lock = Mutex.create () and cond = Condition.create () in
31 (* If a job throws an exception it is saved here. *)
32 let last_exn = ref [] in
34 (* This is the background thread which runs each job. *)
36 let exn = try f (); None with exn -> Some exn in
40 | None -> retire_job job
42 last_exn := exn :: !last_exn;
46 Condition.signal cond;
51 let continue = !last_exn = [] || Cmdline.keep_going () in
53 match next_job () with
56 assert (!running > 0);
57 Cmdline.debug "%d/%d threads running, waiting for dependencies"
58 !running (Cmdline.nr_jobs ());
59 (* Wait for any running thread to finish. *)
60 Condition.wait cond lock;
64 ignore (Thread.create runner (job, f));
65 (* If we've reached the limit on number of threads, wait
66 * for any running thread to finish.
68 while !running >= Cmdline.nr_jobs () do
69 Condition.wait cond lock
77 (* Wait for all jobs to complete. *)
79 Cmdline.debug "%d/%d threads running, waiting for completion"
80 !running (Cmdline.nr_jobs ());
81 Condition.wait cond lock
84 let exns = !last_exn in
87 (* Re-raise the saved exception(s) from the job(s) which failed. *)
92 (* Combine the multiple exceptions into a single Failure exn. *)
93 let exns = List.rev exns in
94 let exn_to_string = function
96 | exn -> Printexc.to_string exn in
97 let exns = List.map exn_to_string exns in
98 let exns = String.concat "\n" exns in