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          if !running > 0 then (
  57            Cmdline.debug "%d/%d threads running, waiting for completion"
  58              !running (Cmdline.nr_jobs ());
  59            Condition.wait cond lock;
  60            loop ()
  61          )
  62       | Not_ready ->
  63          assert (!running > 0);
  64          Cmdline.debug "%d/%d threads running, waiting for dependencies"
  65            !running (Cmdline.nr_jobs ());
  66          (* Wait for any running thread to finish. *)
  67          Condition.wait cond lock;
  68          loop ()
  69       | Job (job, f) ->
  70          incr running;
  71          ignore (Thread.create runner (job, f));
  72          (* If we've reached the limit on number of threads, wait
  73           * for any running thread to finish.
  74           *)
  75          while !running >= Cmdline.nr_jobs () do
  76            Condition.wait cond lock
  77          done;
  78          loop ()
  79     )
  80   in
  81   Mutex.lock lock;
  82   loop ();
  83   let exn = !last_exn in
  84   Mutex.unlock lock;
  85
  86   (* Re-raise the saved exception from the job which failed. *)
  87   match exn with
  88   | None -> ()
  89   | Some exn -> raise exn