cbaines/guile-knots
1
Fork 0
Code Issues Pull requests Activity Actions

Improve promise exception reporting

Browse source 
And guard against calling fibers-force not on a fibers promise record.
This commit is contained in:
Christopher Baines 2025-05-26 14:45:58 +01:00
parent cbafdb8668
commit 8e582a2d73
1 changed files with 57 additions and 29 deletions
Download patch file Download diff file Expand all files Collapse all files

86
knots/promise.scm
View file

@ -19,10 +19,15 @@
(define-module (knots promise)
#:use-module (srfi srfi-9)
#:use-module (ice-9 match)
#:use-module (ice-9 atomic)
#:use-module (ice-9 exceptions)
#:use-module (fibers)
#:use-module (fibers conditions)
#:export (fibers-delay
#:use-module (knots)
#:export (fibers-promise?
fibers-delay
fibers-force
fibers-promise-reset
fibers-promise-result-available?))
@ -41,38 +46,61 @@
(make-condition)))
(define (fibers-force fp)
(unless (fibers-promise? fp)
(raise-exception
(make-exception
(make-exception-with-message "fibers-force: not a fibers promise")
(make-exception-with-irritants fp))))
(let ((res (atomic-box-compare-and-swap!
(fibers-promise-values-box fp)
#f
'started)))
(if (eq? #f res)
(call-with-values
(lambda ()
(with-exception-handler
(lambda (exn)
(atomic-box-set! (fibers-promise-values-box fp)
exn)
(signal-condition!
(fibers-promise-evaluated-condition fp))
(raise-exception exn))
(fibers-promise-thunk fp)
#:unwind? #t))
(lambda vals
(atomic-box-set! (fibers-promise-values-box fp)
vals)
(signal-condition!
(fibers-promise-evaluated-condition fp))
(apply values vals)))
(if (eq? res 'started)
(begin
(wait (fibers-promise-evaluated-condition fp))
(let ((result (atomic-box-ref (fibers-promise-values-box fp))))
(if (exception? result)
(raise-exception result)
(apply values result))))
(if (exception? res)
(raise-exception res)
(apply values res))))))
(cond
((eq? #f res)
(call-with-values
(lambda ()
(with-exception-handler
(lambda (exn)
(atomic-box-set! (fibers-promise-values-box fp)
exn)
(signal-condition!
(fibers-promise-evaluated-condition fp))
(raise-exception exn))
(lambda ()
(with-exception-handler
(lambda (exn)
(let ((stack
(match (fluid-ref %stacks)
((stack-tag . prompt-tag)
(make-stack #t
0 prompt-tag
0 (and prompt-tag 1)))
(_
(make-stack #t)))))
(raise-exception
(make-exception
exn
(make-knots-exception stack)))))
(fibers-promise-thunk fp)))
#:unwind? #t))
(lambda vals
(atomic-box-set! (fibers-promise-values-box fp)
vals)
(signal-condition!
(fibers-promise-evaluated-condition fp))
(apply values vals))))
((eq? res 'started)
(begin
(wait (fibers-promise-evaluated-condition fp))
(let ((result (atomic-box-ref (fibers-promise-values-box fp))))
(if (exception? result)
(raise-exception result)
(apply values result)))))
(else
(if (exception? res)
(raise-exception res)
(apply values res))))))
(define (fibers-promise-reset fp)
(atomic-box-set! (fibers-promise-values-box fp)