From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Thu, 4 Feb 2016 04:23:25 +0000 (-0700)
Subject: Abort the console thread when heap is low.
X-Git-Tag: mit-scheme-pucked-9.2.12~371^2~1
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=660807785c4b92aeb322797c79c787fce91c4c3c;p=mit-scheme.git

Abort the console thread when heap is low.

Previously, a random running thread was aborted, e.g. the
single-threaded workload.  Recently, just the notification subscribers
were aborted.  But it is common for there to be NO subscribers,
e.g. during a single-threaded workload (our own build!).  Now the
console thread is also aborted (and notifications are punted).
---

diff --git a/src/runtime/gc.scm b/src/runtime/gc.scm
index 265b9f8be..e3aeff894 100644
--- a/src/runtime/gc.scm
+++ b/src/runtime/gc.scm
@@ -120,24 +120,23 @@ USA.
   (hook/gc-finish start-value space-remaining)
   ((ucode-primitive request-interrupts! 1) interrupt-bit/after-gc))
 
-(define (abort-if-heap-low space-remaining)
-  (if (< space-remaining 4096)
-      (if gc-boot-loading?
-	  (let ((console ((ucode-primitive tty-output-channel 0))))
-	    ((ucode-primitive channel-write 4)
-	     console
-	     gc-boot-death-message
-	     0
-	     ((ucode-primitive string-length 1) gc-boot-death-message))
-	    ((ucode-primitive exit-with-value 1) #x14))
-	  (abort->nearest
-	   (cmdl-message/append
-	    (cmdl-message/strings "Aborting!: out of memory")
-	    ;; Clean up whatever possible to avoid a reoccurrence.
-	    (cmdl-message/active
-	     (lambda (port)
-	       port
-	       (with-gc-notification! #t gc-clean))))))))
+(define (abort-heap-low)
+  (if gc-boot-loading?
+      (let ((console ((ucode-primitive tty-output-channel 0))))
+	((ucode-primitive channel-write 4)
+	 console
+	 gc-boot-death-message
+	 0
+	 ((ucode-primitive string-length 1) gc-boot-death-message))
+	((ucode-primitive exit-with-value 1) #x14))
+      (abort->nearest
+       (cmdl-message/append
+	(cmdl-message/strings "Aborting!: out of memory")
+	;; Clean up whatever possible to avoid a reoccurrence.
+	(cmdl-message/active
+	 (lambda (port)
+	   port
+	   (with-gc-notification! #t gc-clean)))))))
 
 (define gc-boot-loading?)
 
diff --git a/src/runtime/gcnote.scm b/src/runtime/gcnote.scm
index 949d72cc2..1b69510e9 100644
--- a/src/runtime/gcnote.scm
+++ b/src/runtime/gcnote.scm
@@ -109,20 +109,33 @@ USA.
 
 (define (signal-gc-events)
   (let ((statistic last-statistic))
-    (for-each
-      (lambda (entry)
-	(let ((thread (weak-car entry))
-	      (event (weak-cdr entry)))
-	  (if (and thread event)
-	      (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)))
+    (if (< (gc-statistic/heap-left statistic) 4096)
+	(begin
+	  (for-each
+	    (lambda (entry)
+	      (let ((thread (weak-car entry))
+		    (event (weak-cdr entry)))
+		(if (and thread event)
+		    (signal-event thread abort-heap-low))))
+	    gc-events)
+	  (let ((console-thread
+		 (thread-mutex-owner (port/thread-mutex console-i/o-port))))
+	    (if (not (weak-assq console-thread gc-events))
+		(signal-event console-thread abort-heap-low))))
+	(for-each
+	  (lambda (entry)
+	    (let ((thread (weak-car entry))
+		  (event (weak-cdr entry)))
+	      (if (and thread event)
+		  (signal-event thread (named-lambda (gc-event)
+					 (event statistic))))))
+	  gc-events))))
+
+(define (signal-event thread event)
+  (without-interrupts
+   (lambda ()
+     (if (not (eq? 'DEAD (thread-execution-state thread)))
+	 (%signal-thread-event thread event)))))
 
 (define (weak-assq obj alist)
   (let loop ((alist alist))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index e381d1afd..20ba5c364 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1991,7 +1991,7 @@ USA.
   (export (runtime error-handler)
 	  hook/hardware-trap)
   (export (runtime gc-notification)
-	  abort-if-heap-low)
+	  abort-heap-low)
   (initialization (initialize-package!)))
 
 (define-package (runtime gc-daemons)