From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Fri, 29 Jul 2016 06:56:49 +0000 (-0700)
Subject: Fix suspend-current-thread to NOT leave events unblocked.
X-Git-Tag: mit-scheme-pucked-9.2.12~261^2~21
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e47eaeec8005134b1be82265cd73903c5b415c1d;p=mit-scheme.git

Fix suspend-current-thread to NOT leave events unblocked.

Allow thread events to run in %resume-current-thread if they were
blocked but the thread is suspended, and block them again when the
thread continues.
---

diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 161774b70..5fafca424 100644
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -50,8 +50,10 @@ USA.
   ;; #F if current thread or exited, else continuation for thread.
 
   (block-events? #f)
-  ;; If true, events may not be delivered to this thread.  Instead,
-  ;; they are queued.
+  ;; If #t, events may not run in this thread and should be queued.
+  ;; If 'SUSPENDED, events were blocked when the thread suspended.
+  ;; Events should wake the thread and %resume-current-thread should
+  ;; run them but then it should continue with events blocked (#t).
 
   (pending-events (make-ring) read-only #t)
   ;; Doubly-linked circular list of events waiting to be delivered.
@@ -316,10 +318,12 @@ USA.
 	(%resume-current-thread thread)))))
 
 (define (%resume-current-thread thread)
-  (if (not (thread/block-events? thread))
-      (begin
-	(handle-thread-events thread)
-	(set-thread/block-events?! thread #f)))
+  (let ((block-events? (thread/block-events? thread)))
+    (cond ((eq? #f block-events?)
+	   (handle-thread-events thread))
+	  ((eq? 'suspended block-events?)
+	   (handle-thread-events thread)
+	   (set-thread/block-events?! thread #t))))
   (%maybe-toggle-thread-timer))
 
 (define (suspend-current-thread)
@@ -329,18 +333,18 @@ USA.
   (call-with-current-thread #f
     (lambda (thread)
       (let ((block-events? (thread/block-events? thread)))
-	(set-thread/block-events?! thread #f)
+	(set-thread/block-events?! thread (and block-events? 'suspended))
 	(maybe-signal-io-thread-events)
 	(let ((any-events? (handle-thread-events thread)))
-	  (set-thread/block-events?! thread block-events?)
 	  (if any-events?
-	      (%maybe-toggle-thread-timer)
+	      (begin
+		(set-thread/block-events?! thread block-events?)
+		(%maybe-toggle-thread-timer))
 	      (call-with-current-continuation
 	       (lambda (continuation)
 		 (set-thread/continuation! thread continuation)
 		 (maybe-save-thread-float-environment! thread)
 		 (account-for-times thread (get-system-times))
-		 (set-thread/block-events?! thread #f)
 		 (thread-not-running thread 'WAITING)))))))))
 
 (define (stop-current-thread)
@@ -925,7 +929,7 @@ USA.
 
 (define (%signal-thread-event thread event)
   (%add-pending-event thread event)
-  (if (and (not (thread/block-events? thread))
+  (if (and (not (eq? #t (thread/block-events? thread)))
 	   (eq? 'WAITING (thread/execution-state thread)))
       (%thread-running thread)))