[Guile-commits] 01/02: More robust asyncs.test

[Andy Wingo]

wingo pushed a commit to branch main
in repository guile.

commit 850b724f85e72efbba87aa4ff434a7a868d3ed6f
Author: Andy Wingo <wingo@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)))))