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) (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,38 +46,61 @@
(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
(call-with-values ((eq? #f res)
(lambda () (call-with-values
(with-exception-handler (lambda ()
(lambda (exn) (with-exception-handler
(atomic-box-set! (fibers-promise-values-box fp) (lambda (exn)
exn) (atomic-box-set! (fibers-promise-values-box fp)
(signal-condition! exn)
(fibers-promise-evaluated-condition fp)) (signal-condition!
(raise-exception exn)) (fibers-promise-evaluated-condition fp))
(fibers-promise-thunk fp) (raise-exception exn))
#:unwind? #t)) (lambda ()
(lambda vals (with-exception-handler
(atomic-box-set! (fibers-promise-values-box fp) (lambda (exn)
vals) (let ((stack
(signal-condition! (match (fluid-ref %stacks)
(fibers-promise-evaluated-condition fp)) ((stack-tag . prompt-tag)
(apply values vals))) (make-stack #t
(if (eq? res 'started) 0 prompt-tag
(begin 0 (and prompt-tag 1)))
(wait (fibers-promise-evaluated-condition fp)) (_
(let ((result (atomic-box-ref (fibers-promise-values-box fp)))) (make-stack #t)))))
(if (exception? result) (raise-exception
(raise-exception result) (make-exception
(apply values result)))) exn
(if (exception? res) (make-knots-exception stack)))))
(raise-exception res) (fibers-promise-thunk fp)))
(apply values res)))))) #: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) (define (fibers-promise-reset fp)
(atomic-box-set! (fibers-promise-values-box fp) (atomic-box-set! (fibers-promise-values-box fp)