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

Unwind before calling put-message

Browse source 
As I think this might be more reliable in case the stack contains
something that would introduce a continuation barrier.
This commit is contained in:
Christopher Baines 2025-03-11 11:55:42 +00:00
parent a73fd1ca50
commit da69fd19f3
1 changed files with 47 additions and 40 deletions
Download patch file Download diff file Expand all files Collapse all files

87
knots/parallelism.scm
View file

@ -22,6 +22,7 @@
#:use-module (srfi srfi-71) #:use-module (srfi srfi-71)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 control) #:use-module (ice-9 control)
#:use-module (ice-9 exceptions)
#:use-module (fibers) #:use-module (fibers)
#:use-module (fibers channels) #:use-module (fibers channels)
#:use-module (fibers operations) #:use-module (fibers operations)
@ -43,27 +44,30 @@
(let ((reply (make-channel))) (let ((reply (make-channel)))
(spawn-fiber (spawn-fiber
(lambda () (lambda ()
(call-with-escape-continuation (with-exception-handler
(lambda (return) (lambda (exn)
(with-exception-handler (put-message
(lambda (exn) reply
(match (fluid-ref %stacks) (list 'exception exn)))
((stack-tag . prompt-tag) (lambda ()
(let ((stack (make-stack #t (with-exception-handler
0 prompt-tag (lambda (exn)
0 (and prompt-tag 1)))) (match (fluid-ref %stacks)
(put-message reply ((stack-tag . prompt-tag)
(list 'exception (let ((stack (make-stack #t
(make-exception 0 prompt-tag
exn 0 (and prompt-tag 1))))
(make-knots-exception stack))))))) (raise-exception
(return)) (make-exception
(lambda () exn
(call-with-values (make-knots-exception stack)))))))
(lambda () (lambda ()
(start-stack #t (thunk))) (call-with-values
(lambda vals (lambda ()
(put-message reply vals)))))))) (start-stack #t (thunk)))
(lambda vals
(put-message reply vals))))))
#:unwind? #t))
#:parallel? #t) #:parallel? #t)
reply)) reply))
@ -245,25 +249,28 @@
(get-message process-channel)))) (get-message process-channel))))
(put-message (put-message
reply-channel reply-channel
(call-with-escape-continuation (with-exception-handler
(lambda (return) (lambda (exn)
(with-exception-handler (list 'exception exn))
(lambda (exn) (lambda ()
(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 0 prompt-tag
(make-exception 0 (and prompt-tag 1))))
exn (raise-exception
(make-knots-exception stack)))))))) (make-exception
(lambda () exn
(call-with-values (make-knots-exception stack)))))))
(lambda () (lambda ()
(start-stack #t (apply proc args))) (call-with-values
(lambda vals (lambda ()
(cons 'result vals))))))))))) (start-stack #t (apply proc args)))
(lambda vals
(cons 'result vals))))))
#:unwind? #t)))))
#:parallel? #t)) #:parallel? #t))
(iota parallelism)) (iota parallelism))