From 8d6daf3e5e0536212c5e817be695f764cb881b05 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 9 Feb 2022 17:37:14 +0000 Subject: Switch to guile-fibers@1.1 I think the main change required is just to stop accessing the now missing current-fiber parameter. --- guix-build-coordinator/utils/fibers.scm | 115 ++++++++++++++++---------------- 1 file changed, 57 insertions(+), 58 deletions(-) (limited to 'guix-build-coordinator/utils') diff --git a/guix-build-coordinator/utils/fibers.scm b/guix-build-coordinator/utils/fibers.scm index 5481191..4663adc 100644 --- a/guix-build-coordinator/utils/fibers.scm +++ b/guix-build-coordinator/utils/fibers.scm @@ -25,64 +25,63 @@ (log-exception? (const #t))) "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 _ - (call-with-new-thread - (lambda () - (let init ((args (initializer))) - (parameterize ((%worker-thread-args args)) - (let loop ((current-lifetime lifetime)) - (match (get-message channel) - (((? channel? reply) sent-time (? procedure? proc)) - (let ((time-delay - (- (get-internal-real-time) - sent-time))) - (delay-logger (/ time-delay - internal-time-units-per-second)) - (put-message - reply - (let ((start-time (get-internal-real-time))) - (with-exception-handler - (lambda (exn) - (list 'worker-thread-error - (/ (- (get-internal-real-time) - start-time) - internal-time-units-per-second) - exn)) - (lambda () - (with-throw-handler #t - (lambda () - (call-with-values - (lambda () - (apply proc args)) - (lambda vals - (cons (/ (- (get-internal-real-time) - start-time) - internal-time-units-per-second) - vals)))) - (lambda args - (when (match args - (('%exception exn) - (log-exception? exn)) - (_ #t)) - (simple-format - (current-error-port) - "worker-thread: exception: ~A\n" args) - (backtrace))))) - #:unwind? #t)))))) - (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))) + (let ((channel (make-channel))) + (for-each + (lambda _ + (call-with-new-thread + (lambda () + (let init ((args (initializer))) + (parameterize ((%worker-thread-args args)) + (let loop ((current-lifetime lifetime)) + (match (get-message channel) + (((? channel? reply) sent-time (? procedure? proc)) + (let ((time-delay + (- (get-internal-real-time) + sent-time))) + (delay-logger (/ time-delay + internal-time-units-per-second)) + (put-message + reply + (let ((start-time (get-internal-real-time))) + (with-exception-handler + (lambda (exn) + (list 'worker-thread-error + (/ (- (get-internal-real-time) + start-time) + internal-time-units-per-second) + exn)) + (lambda () + (with-throw-handler #t + (lambda () + (call-with-values + (lambda () + (apply proc args)) + (lambda vals + (cons (/ (- (get-internal-real-time) + start-time) + internal-time-units-per-second) + vals)))) + (lambda args + (when (match args + (('%exception exn) + (log-exception? exn)) + (_ #t)) + (simple-format + (current-error-port) + "worker-thread: exception: ~A\n" args) + (backtrace))))) + #:unwind? #t)))))) + (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)) (define* (call-with-worker-thread channel proc #:key duration-logger) "Send PROC to the worker thread through CHANNEL. Return the result of PROC. -- cgit v1.2.3