diff options
| -rw-r--r-- | guix-data-service/utils.scm | 37 |
1 files changed, 37 insertions, 0 deletions
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? |