aboutsummaryrefslogtreecommitdiff
path: root/guix-build-coordinator/utils
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2022-02-09 17:37:14 +0000
committerChristopher Baines <mail@cbaines.net>2022-02-09 17:37:14 +0000
commit8d6daf3e5e0536212c5e817be695f764cb881b05 (patch)
tree5777a57c58dfa309db12bad55d487d9b2b4f22bb /guix-build-coordinator/utils
parentc5c1ff9fc8dcb24003569c0a37dcda6fcd1fbee2 (diff)
downloadbuild-coordinator-8d6daf3e5e0536212c5e817be695f764cb881b05.tar
build-coordinator-8d6daf3e5e0536212c5e817be695f764cb881b05.tar.gz
Switch to guile-fibers@1.1
I think the main change required is just to stop accessing the now missing current-fiber parameter.
Diffstat (limited to 'guix-build-coordinator/utils')
-rw-r--r--guix-build-coordinator/utils/fibers.scm115
1 files changed, 57 insertions, 58 deletions
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.