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 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 None 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
41 | Some exn -> last_exn := Some exn
44 Condition.signal cond;
49 if !last_exn = None then (
50 match next_job () with
53 assert (!running > 0);
54 Cmdline.debug "%d/%d threads running, waiting for dependencies"
55 !running (Cmdline.nr_jobs ());
56 (* Wait for any running thread to finish. *)
57 Condition.wait cond lock;
61 ignore (Thread.create runner (job, f));
62 (* If we've reached the limit on number of threads, wait
63 * for any running thread to finish.
65 while !running >= Cmdline.nr_jobs () do
66 Condition.wait cond lock
74 (* Wait for all jobs to complete. *)
76 Cmdline.debug "%d/%d threads running, waiting for completion"
77 !running (Cmdline.nr_jobs ());
78 Condition.wait cond lock
81 let exn = !last_exn in
84 (* Re-raise the saved exception from the job which failed. *)
87 | Some exn -> raise exn