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 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
  27
  28   (* Lock and condition for when a thread exits. *)
  29   let lock = Mutex.create () and cond = Condition.create () in
  30
  31   (* If a job throws an exception it is saved here. *)
  32   let last_exn = ref [] in
  33
  34   (* This is the background thread which runs each job. *)
  35   let runner (job, f) =
  36     let exn = try f (); None with exn -> Some exn in
  37
  38     Mutex.lock lock;
  39     (match exn with
  40      | None -> retire_job job
  41      | Some exn ->
  42         last_exn := exn :: !last_exn;
  43         fail_job job
  44     );
  45     decr running;
  46     Condition.signal cond;
  47     Mutex.unlock lock
  48   in
  49
  50   let rec loop () =
  51     let continue = !last_exn = [] || Cmdline.keep_going () in
  52     if continue then (
  53       match next_job () with
  54       | Complete -> ()
  55       | Not_ready ->
  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;
  61          loop ()
  62       | Job (job, f) ->
  63          incr running;
  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.
  67           *)
  68          while !running >= Cmdline.nr_jobs () do
  69            Condition.wait cond lock
  70          done;
  71          loop ()
  72     )
  73   in
  74   Mutex.lock lock;
  75   loop ();
  76
  77   (* Wait for all jobs to complete. *)
  78   while !running > 0 do
  79     Cmdline.debug "%d/%d threads running, waiting for completion"
  80       !running (Cmdline.nr_jobs ());
  81     Condition.wait cond lock
  82   done;
  83
  84   let exns = !last_exn in
  85   Mutex.unlock lock;
  86
  87   (* Re-raise the saved exception(s) from the job(s) which failed. *)
  88   match exns with
  89   | [] -> ()
  90   | [exn] -> raise exn
  91   | exns ->
  92      (* Combine the multiple exceptions into a single Failure exn. *)
  93      let exns = List.rev exns in
  94      let exn_to_string = function
  95        | Failure s -> s
  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
  99      raise (Failure exns)