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