diff options
| -rw-r--r-- | .dir-locals.el | 1 | ||||
| -rw-r--r-- | Makefile.am | 2 | ||||
| -rw-r--r-- | guix/workers.scm | 123 | ||||
| -rw-r--r-- | tests/workers.scm | 45 |
4 files changed, 171 insertions, 0 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index 917fd3004a..a2d1eb8160 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -68,6 +68,7 @@ (eval . (put 'call-with-container 'scheme-indent-function 1)) (eval . (put 'container-excursion 'scheme-indent-function 1)) + (eval . (put 'eventually 'scheme-indent-function 1)) ;; Recognize '~', '+', and '$', as used for gexps, as quotation symbols. ;; This notably allows '(' in Paredit to not insert a space when the diff --git a/Makefile.am b/Makefile.am index c9671e2d14..46f9547117 100644 --- a/Makefile.am +++ b/Makefile.am @@ -61,6 +61,7 @@ MODULES = \ guix/licenses.scm \ guix/graph.scm \ guix/cve.scm \ + guix/workers.scm \ guix/zlib.scm \ guix/build-system.scm \ guix/build-system/ant.scm \ @@ -296,6 +297,7 @@ SCM_TESTS = \ tests/graph.scm \ tests/challenge.scm \ tests/cve.scm \ + tests/workers.scm \ tests/zlib.scm \ tests/file-systems.scm \ tests/system.scm \ diff --git a/guix/workers.scm b/guix/workers.scm new file mode 100644 index 0000000000..e3452d249a --- /dev/null +++ b/guix/workers.scm @@ -0,0 +1,123 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix workers) + #:use-module (ice-9 threads) + #:use-module (ice-9 match) + #:use-module (ice-9 q) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:export (pool? + make-pool + pool-enqueue! + pool-idle? + eventually)) + +;;; Commentary: +;;; +;;; This module implements "worker pools". Worker pools are the low-level +;;; mechanism that's behind futures: there's a fixed set of threads +;;; ("workers") that one can submit work to, and one of them will eventually +;;; pick the submitted tasks. +;;; +;;; Unlike futures, these worker pools are meant to be used for tasks that +;;; have a side-effect. Thus, we never "touch" a task that was submitted like +;;; we "touch" a future. Instead, we simply assume that the task will +;;; eventually complete. +;;; +;;; Code: + +(define-record-type <pool> + (%make-pool queue mutex condvar workers) + pool? + (queue pool-queue) + (mutex pool-mutex) + (condvar pool-condition-variable) + (workers pool-workers)) + +(define-syntax-rule (without-mutex mutex exp ...) + (dynamic-wind + (lambda () + (unlock-mutex mutex)) + (lambda () + exp ...) + (lambda () + (lock-mutex mutex)))) + +(define (worker-thunk mutex condvar pop-queue) + "Return the thunk executed by worker threads." + (define (loop) + (match (pop-queue) + (#f ;empty queue + (wait-condition-variable condvar mutex)) + ((? procedure? proc) + ;; Release MUTEX while executing PROC. + (without-mutex mutex + (catch #t proc + (lambda (key . args) + ;; XXX: In Guile 2.0 ports are not thread-safe, so this could + ;; crash (Guile 2.2 is fine). + (display-backtrace (make-stack #t) (current-error-port)) + (print-exception (current-error-port) + (stack-ref (make-stack #t) 0) + key args)))))) + (loop)) + + (lambda () + (with-mutex mutex + (loop)))) + +(define* (make-pool #:optional (count (current-processor-count))) + "Return a pool of COUNT workers." + (let* ((mutex (make-mutex)) + (condvar (make-condition-variable)) + (queue (make-q)) + (procs (unfold (cut >= <> count) + (lambda (n) + (worker-thunk mutex condvar + (lambda () + (and (not (q-empty? queue)) + (q-pop! queue))))) + 1+ + 0)) + (threads (map (lambda (proc) + (call-with-new-thread proc)) + procs))) + (%make-pool queue mutex condvar threads))) + +(define (pool-enqueue! pool thunk) + "Enqueue THUNK for future execution by POOL." + (with-mutex (pool-mutex pool) + (enq! (pool-queue pool) thunk) + (signal-condition-variable (pool-condition-variable pool)))) + +(define (pool-idle? pool) + "Return true if POOL doesn't have any task in its queue." + (with-mutex (pool-mutex pool) + (q-empty? (pool-queue pool)))) + +(define-syntax-rule (eventually pool exp ...) + "Run EXP eventually on one of the workers of POOL." + (pool-enqueue! pool (lambda () exp ...))) + +;;; Local Variables: +;;; eval: (put 'without-mutex 'scheme-indent-function 1) +;;; End: + +;;; workers.scm ends here diff --git a/tests/workers.scm b/tests/workers.scm new file mode 100644 index 0000000000..44b882f691 --- /dev/null +++ b/tests/workers.scm @@ -0,0 +1,45 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (test-workers) + #:use-module (guix workers) + #:use-module (ice-9 threads) + #:use-module (srfi srfi-64)) + +(test-begin "workers") + +(test-equal "enqueue" + 4242 + (let* ((pool (make-pool)) + (result 0) + (1+! (let ((lock (make-mutex))) + (lambda () + (with-mutex lock + (set! result (+ result 1))))))) + (let loop ((i 4242)) + (unless (zero? i) + (pool-enqueue! pool 1+!) + (loop (- i 1)))) + (let poll () + (unless (pool-idle? pool) + (pk 'busy result) + (sleep 1) + (poll))) + result)) + +(test-end) |