From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Tue, 2 Feb 2016 23:52:05 +0000 (-0700)
Subject: GC daemons may run when there is no current thread(!).
X-Git-Tag: mit-scheme-pucked-9.2.12~371^2~3
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ba92c7c5ad042f9a5efc3a2e9ff289d98de2c7e0;p=mit-scheme.git

GC daemons may run when there is no current thread(!).

Thus they cannot use signal-thread-event which, if there is no current
thread, will not return.  (Why DOES signal-thread-event call
run-thread?)
---

diff --git a/src/runtime/gcnote.scm b/src/runtime/gcnote.scm
index 20815e19d..949d72cc2 100644
--- a/src/runtime/gcnote.scm
+++ b/src/runtime/gcnote.scm
@@ -114,12 +114,14 @@ USA.
 	(let ((thread (weak-car entry))
 	      (event (weak-cdr entry)))
 	  (if (and thread event)
-	      (signal-thread-event
-		  thread
-		(named-lambda (gc-event)
-		  (abort-if-heap-low (gc-statistic/heap-left statistic))
-		  (event statistic))
-		#t))))
+	      (without-interrupts
+	       (lambda ()
+		 (if (not (eq? 'DEAD (thread-execution-state thread)))
+		     (%signal-thread-event
+		         thread
+		       (named-lambda (gc-event)
+			 (abort-if-heap-low (gc-statistic/heap-left statistic))
+			 (event statistic)))))))))
       gc-events)))
 
 (define (weak-assq obj alist)
diff --git a/src/runtime/intrpt.scm b/src/runtime/intrpt.scm
index 5cceb67d9..011bf7971 100644
--- a/src/runtime/intrpt.scm
+++ b/src/runtime/intrpt.scm
@@ -136,9 +136,11 @@ USA.
   (clear-interrupts! interrupt-bit/global-3)
   (cond ((console-thread)
          => (lambda (thread)
-              (signal-thread-event thread
-                (lambda ()
-                  (event-distributor/invoke! event:console-resize)))))))
+	      (without-interrupts
+	       (lambda ()
+		 (%signal-thread-event thread
+		   (lambda ()
+		     (event-distributor/invoke! event:console-resize)))))))))
 
 (define ((illegal-interrupt-handler interrupt-bit)
 	 interrupt-code interrupt-enables)
@@ -191,7 +193,7 @@ USA.
 (define (signal-interrupt hook/interrupt hook/clean-input char interrupt)
   (let ((thread (thread-mutex-owner (port/thread-mutex console-i/o-port))))
     (if thread
-	(signal-thread-event thread
+	(%signal-thread-event thread
 	  (lambda ()
 	    (if hook/interrupt
 		(hook/interrupt))
@@ -244,7 +246,7 @@ USA.
 	(vector-set! system-interrupt-vector character-slot
 		     external-interrupt-handler)
 	(vector-set! interrupt-mask-vector character-slot
-		     interrupt-mask/timer-ok)
+		     interrupt-mask/gc-ok)
 
 	(vector-set! system-interrupt-vector after-gc-slot
 		     after-gc-interrupt-handler)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 95963c599..e381d1afd 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2036,6 +2036,8 @@ USA.
 	  with-gc-notification!)
   (export (runtime thread)
 	  %deregister-gc-event)
+  (import (runtime thread)
+	  %signal-thread-event)
   (initialization (initialize-package!)))
 
 (define-package (runtime gc-statistics)
@@ -2482,6 +2484,8 @@ USA.
 	  generate-suspend-file?)
   (export (runtime swank)
 	  keyboard-interrupt-vector)
+  (import (runtime thread)
+	  %signal-thread-event)
   (initialization (initialize-package!)))
 
 (define-package (runtime lambda-abstraction)