cbaines pushed a commit to branch master
in repository data-service.
commit 7f746b358b07c434fd8df1c5cf4dacf9d0e8698e
Author: Christopher Baines <[email protected]>
AuthorDate: Wed Aug 7 16:50:30 2024 +0100
Add the fiberize utility
---
guix-data-service/utils.scm | 37 +++++++++++++++++++++++++++++++++++++
1 file changed, 37 insertions(+)
diff --git a/guix-data-service/utils.scm b/guix-data-service/utils.scm
index 13dce82..0320497 100644
--- a/guix-data-service/utils.scm
+++ b/guix-data-service/utils.scm
@@ -55,6 +55,8 @@
call-with-worker-thread
worker-thread-timeout-error?
+ fiberize
+
fibers-delay
fibers-force
@@ -698,6 +700,41 @@ If already in the worker thread, call PROC immediately."
(duration-logger duration))
(apply values result)))))))
+(define* (fiberize proc #:key (parallelism 1))
+ (let ((channel (make-channel)))
+ (for-each
+ (lambda _
+ (spawn-fiber
+ (lambda ()
+ (while #t
+ (let ((reply-channel args (car+cdr
+ (get-message channel))))
+ (put-message
+ reply-channel
+ (with-exception-handler
+ (lambda (exn)
+ (cons 'exception exn))
+ (lambda ()
+ (with-throw-handler #t
+ (lambda ()
+ (call-with-values
+ (lambda ()
+ (apply proc args))
+ (lambda vals
+ (cons 'result vals))))
+ (lambda _
+ (backtrace))))
+ #:unwind? #t)))))
+ #:parallel? #t))
+ (iota parallelism))
+
+ (lambda args
+ (let ((reply-channel (make-channel)))
+ (put-message channel (cons reply-channel args))
+ (match (get-message reply-channel)
+ (('result . vals) (apply values vals))
+ (('exception . exn) (raise-exception exn)))))))
+
(define-record-type <fibers-promise>
(make-fibers-promise thunk values-box evaluated-condition)
fibers-promise?
