Add the fiberize utility
This commit is contained in:
parent
3d2335cebe
commit
7f746b358b
1 changed files with 37 additions and 0 deletions
|
|
@ -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?
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue