Add the fiberize utility

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?