diff options
| -rw-r--r-- | guix-build-coordinator/utils/fibers.scm | 22 |
1 files changed, 16 insertions, 6 deletions
diff --git a/guix-build-coordinator/utils/fibers.scm b/guix-build-coordinator/utils/fibers.scm index f6dba70..99941ad 100644 --- a/guix-build-coordinator/utils/fibers.scm +++ b/guix-build-coordinator/utils/fibers.scm @@ -16,18 +16,20 @@ (define* (make-worker-thread-channel initializer #:key (parallelism 1) - (delay-logger (lambda _ #f))) + (delay-logger (lambda _ #f)) + destructor + lifetime) "Return a channel used to offload work to a dedicated thread. ARGS are the arguments of the worker thread procedure." (parameterize (((@@ (fibers internal) current-fiber) #f)) (let ((channel (make-channel))) (for-each (lambda _ - (let ((args (initializer))) - (call-with-new-thread - (lambda () + (call-with-new-thread + (lambda () + (let init ((args (initializer))) (parameterize ((%worker-thread-args args)) - (let loop () + (let loop ((current-lifetime lifetime)) (match (get-message channel) (((? channel? reply) sent-time (? procedure? proc)) (let ((time-delay @@ -53,7 +55,15 @@ arguments of the worker thread procedure." "worker-thread: exception: ~A ~A\n" key args) (backtrace)))) #:unwind? #t))))) - (loop))))))) + (if (number? current-lifetime) + (unless (< current-lifetime 0) + (loop (if current-lifetime + (- current-lifetime 1) + #f))) + (loop #f)))) + (when destructor + (apply destructor args) + (init (initializer)))))) (iota parallelism)) channel))) |