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

Allow passing custom channels to fiberize

Browse source 
This allows customising the behevaiour, for example by using a queue.
This commit is contained in:
Christopher Baines 2025-02-19 12:46:51 +00:00
parent ca3d5a1781
commit 99245034ea
1 changed files with 43 additions and 41 deletions
Download patch file Download diff file Expand all files Collapse all files

84
knots/parallelism.scm
View file

@ -238,45 +238,47 @@
#f)))) #f))))
channels-to-results)))))))) channels-to-results))))))))
(define* (fiberize proc #:key (parallelism 1)) (define* (fiberize proc
(let ((channel (make-channel))) #:key (parallelism 1)
(for-each (input-channel (make-channel))
(lambda _ (process-channel input-channel))
(spawn-fiber (for-each
(lambda () (lambda _
(while #t (spawn-fiber
(let ((reply-channel args (car+cdr (lambda ()
(get-message channel)))) (while #t
(put-message (let ((reply-channel args (car+cdr
reply-channel (get-message process-channel))))
(call-with-escape-continuation (put-message
(lambda (return) reply-channel
(with-exception-handler (call-with-escape-continuation
(lambda (exn) (lambda (return)
(match (fluid-ref %stacks) (with-exception-handler
((stack-tag . prompt-tag) (lambda (exn)
(let ((stack (make-stack #t (match (fluid-ref %stacks)
0 prompt-tag ((stack-tag . prompt-tag)
0 (and prompt-tag 1)))) (let ((stack (make-stack #t
(return (list 'exception exn stack)))))) 0 prompt-tag
(lambda () 0 (and prompt-tag 1))))
(call-with-values (return (list 'exception exn stack))))))
(lambda () (lambda ()
(start-stack #t (apply proc args))) (call-with-values
(lambda vals (lambda ()
(cons 'result vals))))))))))) (start-stack #t (apply proc args)))
#:parallel? #t)) (lambda vals
(iota parallelism)) (cons 'result vals)))))))))))
#:parallel? #t))
(iota parallelism))
(lambda args (lambda args
(let ((reply-channel (make-channel))) (let ((reply-channel (make-channel)))
(put-message channel (cons reply-channel args)) (put-message input-channel (cons reply-channel args))
(match (get-message reply-channel) (match (get-message reply-channel)
(('result . vals) (apply values vals)) (('result . vals) (apply values vals))
(('exception exn stack) (('exception exn stack)
(let ((knots-exn (let ((knots-exn
(make-knots-exception stack))) (make-knots-exception stack)))
(raise-exception (raise-exception
(make-exception (make-exception
knots-exn knots-exn
exn))))))))) exn))))))))