From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Tue, 18 Aug 2015 00:19:15 +0000 (-0700)
Subject: Add register-gc-event, deregister-gc-event, registered-gc-event.
X-Git-Tag: mit-scheme-pucked-9.2.12~376^2~16
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1d15962559677b00b0c931131c86e320c393fe87;p=mit-scheme.git

Add register-gc-event, deregister-gc-event, registered-gc-event.

Punt the hook/record-statistic! fluid.  With-gc-notification now uses
dynamic-wind to register and deregister a GC thread event for the
current thread.

Do not use ANY fluid state (e.g. nearest-cmdl/port) during a GC.  Use
the console-i/o-port in hook/gc-start and hook/gc-finish.  GCs can
happen in the thread system when there is no current thread.

The fluid state IS defined during the GC thread events.  At the start
of such events, signal a REPL abort if the heap is low.
---

diff --git a/src/runtime/gc.scm b/src/runtime/gc.scm
index 6693fcc60..d04895603 100644
--- a/src/runtime/gc.scm
+++ b/src/runtime/gc.scm
@@ -117,6 +117,10 @@ USA.
   #f)
 
 (define (gc-finish start-value space-remaining)
+  (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))))
@@ -133,9 +137,7 @@ USA.
 	    (cmdl-message/active
 	     (lambda (port)
 	       port
-	       (with-gc-notification! #t gc-clean)))))))
-  ((ucode-primitive request-interrupts! 1) interrupt-bit/after-gc)
-  (hook/gc-finish start-value space-remaining))
+	       (with-gc-notification! #t gc-clean))))))))
 
 (define gc-boot-loading?)
 
diff --git a/src/runtime/gcnote.scm b/src/runtime/gcnote.scm
index 6c3357600..e612ae658 100644
--- a/src/runtime/gcnote.scm
+++ b/src/runtime/gcnote.scm
@@ -29,30 +29,109 @@ USA.
 
 (declare (usual-integrations))
 
+(define (initialize-package!)
+  (add-gc-daemon! signal-gc-events))
+
 (define (toggle-gc-notification!)
-  (set-fluid! hook/record-statistic!
-	      (let ((current (fluid hook/record-statistic!)))
-		(cond ((eq? current gc-notification) default/record-statistic!)
-		      ((eq? current default/record-statistic!) gc-notification)
-		      (else (error "Can't grab GC statistics hook")))))
+  (if (registered-gc-event)
+      (deregister-gc-event)
+      (register-gc-event gc-notification))
   unspecific)
 
 (define (set-gc-notification! #!optional on?)
   (let ((on? (if (default-object? on?) #T on?)))
-    (set-fluid! hook/record-statistic!
-		(let ((current (fluid hook/record-statistic!)))
-		  (if (or (eq? current gc-notification)
-			  (eq? current default/record-statistic!))
-		      (if on?
-			  gc-notification
-			  default/record-statistic!)
-		      (error "Can't grab GC statistics hook"))))
+    (if on?
+	(register-gc-event gc-notification)
+	(deregister-gc-event))
     unspecific))
 
 (define (with-gc-notification! notify? thunk)
-  (let-fluid hook/record-statistic!
-	     (if notify? gc-notification default/record-statistic!)
-    thunk))
+  (let ((outside))
+    (dynamic-wind
+     (lambda ()
+       (set! outside (registered-gc-event))
+       (if notify?
+	   (register-gc-event gc-notification)
+	   (deregister-gc-event)))
+     thunk
+     (lambda ()
+       (if outside
+	   (register-gc-event outside)
+	   (deregister-gc-event))
+       (set! outside)))))
+
+;;;; GC Events
+
+(define gc-events '())			;Weak alist of threads X events.
+(define gc-events-mutex (make-thread-mutex))
+
+(define (register-gc-event event)
+  (guarantee-procedure-of-arity event 1 'register-gc-event)
+  (with-thread-mutex-lock gc-events-mutex
+    (lambda ()
+      (clean-gc-events)
+      (let* ((thread (current-thread))
+	     (entry (weak-assq thread gc-events)))
+	(if entry
+	    (weak-set-cdr! entry event)
+	    (set! gc-events (cons (weak-cons thread event) gc-events)))))))
+
+(define (deregister-gc-event)
+  (with-thread-mutex-lock gc-events-mutex
+    (lambda ()
+      (clean-gc-events)
+      (let* ((thread (current-thread))
+	     (entry (weak-assq thread gc-events)))
+	(if entry
+	    (set! gc-events (delq! entry gc-events)))))))
+
+(define (%deregister-gc-event thread)
+  ;; This procedure is called by the thread system when a thread exits
+  ;; or calls deregister-all-events.  It may interrupt the procedures
+  ;; above, but it does not modify the gc-events list.  Fortunately a
+  ;; thread cannot race itself to both set and clear its entry.
+  (let ((entry (weak-assq thread gc-events)))
+    (if entry
+	(weak-set-cdr! entry #f))))
+
+(define (clean-gc-events)
+  (set! gc-events
+	(filter! (lambda (weak)
+		   (let ((thread (weak-car weak)))
+		     (and thread
+			  (weak-cdr weak) ;not cleared by %deregister...
+			  (not (eq? 'DEAD (thread-execution-state thread))))))
+		 gc-events)))
+
+(define (registered-gc-event)
+  (let ((entry (weak-assq (current-thread) gc-events)))
+    (and entry (weak-cdr entry))))
+
+(define (signal-gc-events)
+  (for-each
+    (lambda (entry)
+      (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 last-statistic))
+		(event last-statistic))
+	      #t))))
+    gc-events))
+
+(define (weak-assq obj alist)
+  (let loop ((alist alist))
+    (if (pair? alist)
+	(let* ((entry (car alist))
+	       (key (weak-car entry)))
+	  (if (eq? key obj)
+	      entry
+	      (loop (cdr alist))))
+	#f)))
+
+;;;; Output
 
 (define (gc-notification statistic)
   (print-statistic statistic (notification-output-port)))
diff --git a/src/runtime/gcstat.scm b/src/runtime/gcstat.scm
index c9c25b300..532d1113e 100644
--- a/src/runtime/gcstat.scm
+++ b/src/runtime/gcstat.scm
@@ -30,7 +30,6 @@ USA.
 (declare (usual-integrations))
 
 (define (initialize-package!)
-  (set! hook/record-statistic! (make-fluid default/record-statistic!))
   (set! history-modes
 	`((NONE . ,none:install-history!)
 	  (BOUNDED . ,bounded:install-history!)
@@ -44,7 +43,7 @@ USA.
   unspecific)
 
 (define (recorder/gc-start)
-  (port/gc-start (nearest-cmdl/port))
+  (port/gc-start console-i/o-port)
   (set! this-gc-start-clock (real-time-clock))
   (set! this-gc-start (process-time-clock))
   unspecific)
@@ -57,7 +56,7 @@ USA.
     (statistics-flip this-gc-start end-time
 		     space-remaining
 		     this-gc-start-clock end-time-clock))
-  (port/gc-finish (nearest-cmdl/port)))
+  (port/gc-finish console-i/o-port))
 
 (define timestamp)
 (define total-gc-time)
@@ -105,18 +104,11 @@ USA.
     (set! last-gc-end end-time)
     (set! last-gc-start-clock start-clock)
     (set! last-gc-end-clock end-clock)
-    (record-statistic! statistic)
-    ((fluid hook/record-statistic!) statistic)))
+    (record-statistic! statistic)))
 
 (define (gc-statistic/meter stat)
   (car (gc-statistic/timestamp stat)))
 
-(define hook/record-statistic!)
-
-(define (default/record-statistic! statistic)
-  statistic
-  false)
-
 (define (gctime)
   (internal-time/ticks->seconds total-gc-time))
 
diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 6ca4c4376..8698ddba6 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -518,6 +518,7 @@ USA.
    ;; REP Loops
    (RUNTIME INTERRUPT-HANDLER)
    (RUNTIME GC-STATISTICS)
+   (RUNTIME GC-NOTIFICATION)
    (RUNTIME REP)
    ;; Debugging
    (RUNTIME COMPILER-INFO)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 4f06036c8..0a1dc5718 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1990,6 +1990,8 @@ USA.
 	  hook/gc-start)
   (export (runtime error-handler)
 	  hook/hardware-trap)
+  (export (runtime gc-notification)
+	  abort-if-heap-low)
   (initialization (initialize-package!)))
 
 (define-package (runtime gc-daemons)
@@ -2024,11 +2026,17 @@ USA.
   (files "gcnote")
   (parent (runtime))
   (export ()
+	  deregister-gc-event
 	  gc-statistic->string
 	  print-gc-statistics
+	  register-gc-event
+	  registered-gc-event
 	  set-gc-notification!
 	  toggle-gc-notification!
-	  with-gc-notification!))
+	  with-gc-notification!)
+  (export (runtime thread)
+	  %deregister-gc-event)
+  (initialization (initialize-package!)))
 
 (define-package (runtime gc-statistics)
   (files "gcstat")
@@ -2049,8 +2057,7 @@ USA.
 	  gc-timestamp
 	  gctime)
   (export (runtime gc-notification)
-	  default/record-statistic!
-	  hook/record-statistic!)
+	  last-statistic)
   (initialization (initialize-package!)))
 
 (define-package (runtime generic-i/o-port)
diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 1e01c3b01..62abda604 100644
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -858,9 +858,11 @@ USA.
 	   (set-thread/block-events?! thread block?)))
      unspecific)))
 
-(define (signal-thread-event thread event)
+(define (signal-thread-event thread event #!optional no-error?)
   (guarantee-thread thread 'SIGNAL-THREAD-EVENT)
-  (let ((self first-running-thread))
+  (let ((self first-running-thread)
+	(noerr? (and (not (default-object? no-error?))
+		     no-error?)))
     (if (eq? thread self)
 	(let ((block-events? (block-thread-events)))
 	  (%add-pending-event thread event)
@@ -869,12 +871,14 @@ USA.
 	(without-interrupts
 	 (lambda ()
 	   (if (eq? 'DEAD (thread/execution-state thread))
-	       (signal-thread-dead thread "signal event to"
-				   signal-thread-event thread event))
-	   (%signal-thread-event thread event)
-	   (if (and (not self) first-running-thread)
-	       (run-thread first-running-thread)
-	       (%maybe-toggle-thread-timer)))))))
+	       (if (not noerr?)
+		   (signal-thread-dead thread "signal event to"
+				       signal-thread-event thread event))
+	       (begin
+		 (%signal-thread-event thread event)
+		 (if (and (not self) first-running-thread)
+		     (run-thread first-running-thread)
+		     (%maybe-toggle-thread-timer)))))))))
 
 (define (%signal-thread-event thread event)
   (%add-pending-event thread event)