wingo pushed a commit to branch main
in repository guile.
commit 850b724f85e72efbba87aa4ff434a7a868d3ed6f
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Mon Sep 18 15:24:37 2023 +0200
More robust asyncs.test
* 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.
---
test-suite/tests/asyncs.test | 40 +++++++++++++++++++---------------------
1 file changed, 19 insertions(+), 21 deletions(-)
diff --git a/test-suite/tests/asyncs.test b/test-suite/tests/asyncs.test
index 4ac9020c4..06190322b 100644
--- a/test-suite/tests/asyncs.test
+++ b/test-suite/tests/asyncs.test
@@ -82,11 +82,10 @@
(with-sigprof-interrupts
1000 ; Hz
(lambda ()
- ;; Could throw an exception if the prompt is
- ;; not active (i.e. interrupt happens
- ;; outside running a cothread). Ignore in
- ;; that case.
- (false-if-exception (abort-to-prompt preempt-tag)))
+ ;; Interrupt could fire outside running a cothread, or
+ ;; recursively within an async; ignore in that case.
+ (when (suspendable-continuation? preempt-tag)
+ (abort-to-prompt preempt-tag)))
run-cothreads)
(equal? (atomic-box-ref box) 100))))
@@ -118,22 +117,21 @@
(atomic-box-set! box (1+ x)))
(lp))))))
(let* ((main-thread (current-thread))
- (preempt-thread (call-with-new-thread
- (lambda ()
- (let lp ()
- (unless (= (atomic-box-ref box) 100)
- (usleep 1000)
- (system-async-mark
- (lambda ()
- ;; Could throw an exception if the
- ;; prompt is not active
- ;; (i.e. interrupt happens outside
- ;; running a cothread). Ignore in
- ;; that case.
- (false-if-exception
- (abort-to-prompt preempt-tag)))
- main-thread)
- (lp)))))))
+ (preempt-thread
+ (call-with-new-thread
+ (lambda ()
+ (let lp ()
+ (unless (= (atomic-box-ref box) 100)
+ (usleep 1000)
+ (system-async-mark
+ (lambda ()
+ ;; Interrupt could fire outside running a
+ ;; cothread, or recursively within an async;
+ ;; ignore in that case.
+ (when (suspendable-continuation? preempt-tag)
+ (abort-to-prompt preempt-tag)))
+ main-thread)
+ (lp)))))))
(run-cothreads)
(join-thread preempt-thread)
(equal? (atomic-box-ref box) 100)))))
