From 967372c23d9b68d011993435cc91e99e26616c20 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 13 Feb 2012 16:16:23 -0700
Subject: [PATCH] make an eventspace thread survive a break exception

When an eventspace is created, its thread implicitly calls
`yield'. It now effectively loops with `yield' and while
catching continuation aborts.

Closes PR 12566
---
 collects/mred/private/wx/common/queue.rkt | 35 ++++++++++++++++-------
 collects/tests/gracket/paramz.rktl        | 19 ++++++++++++
 2 files changed, 43 insertions(+), 11 deletions(-)

diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt
index c1c5903721..1fd4febaa3 100644
--- a/collects/mred/private/wx/common/queue.rkt
+++ b/collects/mred/private/wx/common/queue.rkt
@@ -383,17 +383,30 @@
 (define make-new-eventspace
   (let ([make-eventspace
          (lambda ()
-           (letrec ([pause (make-semaphore)]
-                    [es
-                     (make-eventspace*
-                      (thread
-                       (lambda ()
-                         (sync pause)
-                         (thread-cell-set! handler-thread-of es)
-                         (current-eventspace es)
-                         (yield (make-semaphore)))))])
-             (semaphore-post pause)
-             es))])
+           (define pause (make-semaphore))
+           (define break-paramz (current-break-parameterization))
+           (define es
+             (make-eventspace*
+              (parameterize-break 
+               #f ; disable breaks until we're in the yield loop
+               (thread
+                (lambda ()
+                  (sync pause) ; wait until `es' has a value
+                  (thread-cell-set! handler-thread-of es)
+                  (current-eventspace es)
+                  (let loop ()
+                    (call-with-continuation-prompt
+                     (lambda ()
+                       ;; re-enable breaks (if they are supposed to be enabled):
+                       (call-with-break-parameterization
+                        break-paramz
+                        (lambda () 
+                          ;; yield; any abort (including a break exception)
+                          ;; will get caught and the loop will yield again
+                          (yield (make-semaphore))))))
+                    (loop)))))))
+           (semaphore-post pause) ; `es' has a value
+           es)])
     make-eventspace))
 
 (define (queue-event eventspace thunk [level 'med])
diff --git a/collects/tests/gracket/paramz.rktl b/collects/tests/gracket/paramz.rktl
index 36e7697a1e..ad5dbe1fa5 100644
--- a/collects/tests/gracket/paramz.rktl
+++ b/collects/tests/gracket/paramz.rktl
@@ -105,4 +105,23 @@
 (try-use-es (lambda () (queue-callback void)))
 (try-use-es (lambda () (send tmr start 100 #t)))
 
+;; ----------------------------------------
+;;  Check that breaking an eventspace thread doesn't kill it:
+
+(let ()
+  (define evtsp (make-eventspace))
+  (define evtth (eventspace-handler-thread evtsp))
+  
+  (sleep 0.1)
+  (break-thread evtth)
+
+  (define done (make-semaphore))
+  (parameterize ((current-eventspace evtsp))
+    (queue-callback (lambda () (semaphore-post done))))
+
+  (unless (sync/timeout 3 done)
+    (error "broken thread is really broken")))
+
+;; ----------------------------------------
+
 (report-errs)