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 265b9f8be23dfae5ac80e0918a7589fa3a3063d1..e3aeff894fbeab3e964d9419f908766ed11bab86 100644 (file)
--- 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 949d72cc2c6e4324208234105b79fe942e63c891..1b69510e9f634b72bd50c12d4624a2257a624a16 100644 (file)
--- 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 e381d1afd894c9c5676fd9748da603fc30f6da06..20ba5c364a3d7ce8460b1b8bc25af48a236c1c93 100644 (file)
--- 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)