cbaines/guile-knots
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add fiberize

Browse source 
Not sure about the name yet, but this is useful.
This commit is contained in:
Christopher Baines 2025-01-08 15:57:15 +00:00
parent 409fa1df5c
commit 59c183b13f
1 changed files with 40 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

41
knots/parallelism.scm
View file

@ -33,7 +33,9 @@
fibers-for-each
fibers-parallel
fibers-let))
fibers-let
fiberize))
(define (defer-to-parallel-fiber thunk)
(let ((reply (make-channel)))
@ -219,3 +221,40 @@
channels-to-results)))
#f))))
channels-to-results))))))))
(define* (fiberize proc #:key (parallelism 1)
(show-backtrace? (const #t)))
(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 args
(when (apply show-backtrace? args)
(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)))))))