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 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 None 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 -> last_exn := Some exn
  42     );
  43     decr running;
  44     Condition.signal cond;
  45     Mutex.unlock lock
  46   in
  47
  48   let rec loop () =
  49     if !last_exn = None then (
  50       match next_job () with
  51       | Complete -> ()
  52       | Not_ready ->
  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;
  58          loop ()
  59       | Job (job, f) ->
  60          incr running;
  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.
  64           *)
  65          while !running >= Cmdline.nr_jobs () do
  66            Condition.wait cond lock
  67          done;
  68          loop ()
  69     )
  70   in
  71   Mutex.lock lock;
  72   loop ();
  73
  74   (* Wait for all jobs to complete. *)
  75   while !running > 0 do
  76     Cmdline.debug "%d/%d threads running, waiting for completion"
  77       !running (Cmdline.nr_jobs ());
  78     Condition.wait cond lock
  79   done;
  80
  81   let exn = !last_exn in
  82   Mutex.unlock lock;
  83
  84   (* Re-raise the saved exception from the job which failed. *)
  85   match exn with
  86   | None -> ()
  87   | Some exn -> raise exn