Add the fiberize utility

This commit is contained in:
Christopher Baines 2024-08-07 16:50:30 +01:00
parent 3d2335cebe
commit 7f746b358b

View file

@ -55,6 +55,8 @@
call-with-worker-thread call-with-worker-thread
worker-thread-timeout-error? worker-thread-timeout-error?
fiberize
fibers-delay fibers-delay
fibers-force fibers-force
@ -698,6 +700,41 @@ If already in the worker thread, call PROC immediately."
(duration-logger duration)) (duration-logger duration))
(apply values result))))))) (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> (define-record-type <fibers-promise>
(make-fibers-promise thunk values-box evaluated-condition) (make-fibers-promise thunk values-box evaluated-condition)
fibers-promise? fibers-promise?