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

40
knots/promise.scm
View file

@ -19,10 +19,15 @@
(define-module (knots promise) (define-module (knots promise)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (ice-9 match)
#:use-module (ice-9 atomic) #:use-module (ice-9 atomic)
#:use-module (ice-9 exceptions)
#:use-module (fibers) #:use-module (fibers)
#:use-module (fibers conditions) #:use-module (fibers conditions)
#:export (fibers-delay #:use-module (knots)
#:export (fibers-promise?
fibers-delay
fibers-force fibers-force
fibers-promise-reset fibers-promise-reset
fibers-promise-result-available?)) fibers-promise-result-available?))
@ -41,11 +46,18 @@
(make-condition))) (make-condition)))
(define (fibers-force fp) (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! (let ((res (atomic-box-compare-and-swap!
(fibers-promise-values-box fp) (fibers-promise-values-box fp)
#f #f
'started))) 'started)))
(if (eq? #f res) (cond
((eq? #f res)
(call-with-values (call-with-values
(lambda () (lambda ()
(with-exception-handler (with-exception-handler
@ -55,21 +67,37 @@
(signal-condition! (signal-condition!
(fibers-promise-evaluated-condition fp)) (fibers-promise-evaluated-condition fp))
(raise-exception exn)) (raise-exception exn))
(fibers-promise-thunk fp) (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)) #:unwind? #t))
(lambda vals (lambda vals
(atomic-box-set! (fibers-promise-values-box fp) (atomic-box-set! (fibers-promise-values-box fp)
vals) vals)
(signal-condition! (signal-condition!
(fibers-promise-evaluated-condition fp)) (fibers-promise-evaluated-condition fp))
(apply values vals))) (apply values vals))))
(if (eq? res 'started) ((eq? res 'started)
(begin (begin
(wait (fibers-promise-evaluated-condition fp)) (wait (fibers-promise-evaluated-condition fp))
(let ((result (atomic-box-ref (fibers-promise-values-box fp)))) (let ((result (atomic-box-ref (fibers-promise-values-box fp))))
(if (exception? result) (if (exception? result)
(raise-exception result) (raise-exception result)
(apply values result)))) (apply values result)))))
(else
(if (exception? res) (if (exception? res)
(raise-exception res) (raise-exception res)
(apply values res)))))) (apply values res))))))