src/jobs.ml

   1 (* Goals parallel jobs.
   2  * Copyright (C) 2020 Richard W.M. Jones
   3  * Copyright (C) 2020 Red Hat Inc.
   4  *
   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.
   9  *
  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.
  14  *
  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.
  18  *)
  19
  20 open Utils
  21
  22 type 'a next = Job of 'a * (unit -> unit) | Complete | Not_ready
  23
  24 type 'a retire = 'a -> unit
  25
  26 type 'a to_string = 'a -> string
  27
  28 let run next_job retire_job string_of_job =
  29   (* Number of running threads <= Cmdline.nr_jobs. *)
  30   let running = ref 0 in
  31
  32   (* Lock and condition for when a thread exits. *)
  33   let lock = Mutex.create () and cond = Condition.create () in
  34
  35   (* If a job throws an exception it is saved here. *)
  36   let last_exn = ref None in
  37
  38   (* This is the background thread which runs each job. *)
  39   let runner (job, f) =
  40     let exn = try f (); None with exn -> Some exn in
  41
  42     Mutex.lock lock;
  43     (match exn with
  44      | None -> retire_job job
  45      | Some exn -> last_exn := Some exn
  46     );
  47     decr running;
  48     Condition.signal cond;
  49     Mutex.unlock lock
  50   in
  51
  52   let rec loop () =
  53     if !last_exn = None then (
  54       match next_job () with
  55       | Complete -> ()
  56       | Not_ready ->
  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;
  62          loop ()
  63       | Job (job, f) ->
  64          incr running;
  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.
  68           *)
  69          while !running >= Cmdline.nr_jobs () do
  70            Condition.wait cond lock
  71          done;
  72          loop ()
  73     )
  74   in
  75   Mutex.lock lock;
  76   loop ();
  77
  78   (* Wait for all jobs to complete. *)
  79   while !running > 0 do
  80     Cmdline.debug "%d/%d threads running, waiting for completion"
  81       !running (Cmdline.nr_jobs ());
  82     Condition.wait cond lock
  83   done;
  84
  85   let exn = !last_exn in
  86   Mutex.unlock lock;
  87
  88   (* Re-raise the saved exception from the job which failed. *)
  89   match exn with
  90   | None -> ()
  91   | Some exn -> raise exn