mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

More robust asyncs.test

Browse source 
* test-suite/tests/asyncs.test: Instead of wrapping abort-to-prompt with
false-if-exception, to handle edge cases, guard with
suspendable-continuation?: this also catches recursive invocations.
This commit is contained in:
Andy Wingo 2023-09-18 15:24:37 +02:00
parent 1ad31adf30
commit 850b724f85
1 changed files with 19 additions and 21 deletions
Download patch file Download diff file Expand all files Collapse all files

40
test-suite/tests/asyncs.test
View file

@ -82,11 +82,10 @@
(with-sigprof-interrupts (with-sigprof-interrupts
1000 ; Hz 1000 ; Hz
(lambda () (lambda ()
;; Could throw an exception if the prompt is ;; Interrupt could fire outside running a cothread, or
;; not active (i.e. interrupt happens ;; recursively within an async; ignore in that case.
;; outside running a cothread). Ignore in (when (suspendable-continuation? preempt-tag)
;; that case. (abort-to-prompt preempt-tag)))
(false-if-exception (abort-to-prompt preempt-tag)))
run-cothreads) run-cothreads)
(equal? (atomic-box-ref box) 100)))) (equal? (atomic-box-ref box) 100))))
@ -118,22 +117,21 @@
(atomic-box-set! box (1+ x))) (atomic-box-set! box (1+ x)))
(lp)))))) (lp))))))
(let* ((main-thread (current-thread)) (let* ((main-thread (current-thread))
(preempt-thread (call-with-new-thread (preempt-thread
(lambda () (call-with-new-thread
(let lp () (lambda ()
(unless (= (atomic-box-ref box) 100) (let lp ()
(usleep 1000) (unless (= (atomic-box-ref box) 100)
(system-async-mark (usleep 1000)
(lambda () (system-async-mark
;; Could throw an exception if the (lambda ()
;; prompt is not active ;; Interrupt could fire outside running a
;; (i.e. interrupt happens outside ;; cothread, or recursively within an async;
;; running a cothread). Ignore in ;; ignore in that case.
;; that case. (when (suspendable-continuation? preempt-tag)
(false-if-exception (abort-to-prompt preempt-tag)))
(abort-to-prompt preempt-tag))) main-thread)
main-thread) (lp)))))))
(lp)))))))
(run-cothreads) (run-cothreads)
(join-thread preempt-thread) (join-thread preempt-thread)
(equal? (atomic-box-ref box) 100))))) (equal? (atomic-box-ref box) 100)))))