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 type 'a retire = 'a -> unit
26 type 'a to_string = 'a -> string
28 let run next_job retire_job string_of_job =
29 (* Number of running threads <= Cmdline.nr_jobs. *)
30 let running = ref 0 in
32 (* Lock and condition for when a thread exits. *)
33 let lock = Mutex.create () and cond = Condition.create () in
35 (* If a job throws an exception it is saved here. *)
36 let last_exn = ref None in
38 (* This is the background thread which runs each job. *)
40 let exn = try f (); None with exn -> Some exn in
44 | None -> retire_job job
45 | Some exn -> last_exn := Some exn
48 Condition.signal cond;
53 if !last_exn = None then (
54 match next_job () with
57 assert (!running > 0);
58 Cmdline.debug "%d/%d threads running, waiting for dependencies"
59 !running (Cmdline.nr_jobs ());
60 (* Wait for any running thread to finish. *)
61 Condition.wait cond lock;
65 ignore (Thread.create runner (job, f));
66 (* If we've reached the limit on number of threads, wait
67 * for any running thread to finish.
69 while !running >= Cmdline.nr_jobs () do
70 Condition.wait cond lock
78 (* Wait for all jobs to complete. *)
80 Cmdline.debug "%d/%d threads running, waiting for completion"
81 !running (Cmdline.nr_jobs ());
82 Condition.wait cond lock
85 let exn = !last_exn in
88 (* Re-raise the saved exception from the job which failed. *)
91 | Some exn -> raise exn