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

Hook/record-statistic! is now a simple procedure or #F; it is no
longer a fluid.  With-gc-notification now uses dynamic-wind to
register and deregister a thread event for the current thread.

diff --git a/src/runtime/gc.scm b/src/runtime/gc.scm
index 6693fcc6043ffcdeeafee95cef98c5d3d2806dec..1084fc5b59418967f95dd24dda9885fa9cf4147e 100644 (file)
--- a/src/runtime/gc.scm
+++ b/src/runtime/gc.scm
@@ -117,6 +117,10 @@ USA.
   #f)
 
 (define (gc-finish start-value space-remaining)
+  ((ucode-primitive request-interrupts! 1) interrupt-bit/after-gc)
+  (hook/gc-finish start-value space-remaining))
+
+(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 6c3357600f0bb24b4d1693fea4cf9c7b38ee3dce..5388bc5a3c0a8394675dfacdb2510f1fe01532cf 100644 (file)
--- a/src/runtime/gcnote.scm
+++ b/src/runtime/gcnote.scm
@@ -29,30 +29,38 @@ USA.
 
 (declare (usual-integrations))
 \f
+(define (initialize-package!)
+  ;; This hook is run via hook/gc-finish and hook/gc-flip, with
+  ;; absolutely no interrupts(!).
+  (set! hook/record-statistic! 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)))))
 
 (define (gc-notification statistic)
   (print-statistic statistic (notification-output-port)))

diff --git a/src/runtime/gcstat.scm b/src/runtime/gcstat.scm
index c9c25b3001eb4ff2f561a0a350c940b43d66ef52..48208525e7b72efbac6e47fa9d9e932f82193e23 100644 (file)
--- a/src/runtime/gcstat.scm
+++ b/src/runtime/gcstat.scm
@@ -30,7 +30,7 @@ USA.
 (declare (usual-integrations))
 
 (define (initialize-package!)
-  (set! hook/record-statistic! (make-fluid default/record-statistic!))
+  (set! hook/record-statistic! #f)
   (set! history-modes
        `((NONE . ,none:install-history!)
          (BOUNDED . ,bounded:install-history!)
@@ -106,17 +106,14 @@ USA.
     (set! last-gc-start-clock start-clock)
     (set! last-gc-end-clock end-clock)
     (record-statistic! statistic)
-    ((fluid hook/record-statistic!) statistic)))
+    (if hook/record-statistic!
+       (hook/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))
 \f

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 6ca4c43761aed92ce2690b5c696408dcd9dd1b62..8698ddba6b4e6ca4626f4503f642f4d898b443b4 100644 (file)
--- 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 f7841a18509feec5d0d44d03e3972486e0fb2189..1fd7fa244eafa1b680322d0c26118649e83e4e3b 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1969,6 +1969,8 @@ USA.
          hook/gc-start)
   (export (runtime error-handler)
          hook/hardware-trap)
+  (export (runtime thread)
+         abort-if-heap-low)
   (initialization (initialize-package!)))
 
 (define-package (runtime gc-daemons)
@@ -2002,12 +2004,15 @@ USA.
 (define-package (runtime gc-notification)
   (files "gcnote")
   (parent (runtime))
+  (export (runtime thread)
+         signal-gc-events)
   (export ()
          gc-statistic->string
          print-gc-statistics
          set-gc-notification!
          toggle-gc-notification!
-         with-gc-notification!))
+         with-gc-notification!)
+  (initialization (initialize-package!)))
 
 (define-package (runtime gc-statistics)
   (files "gcstat")
@@ -2028,7 +2033,6 @@ USA.
          gc-timestamp
          gctime)
   (export (runtime gc-notification)
-         default/record-statistic!
          hook/record-statistic!)
   (initialization (initialize-package!)))
 
@@ -5034,6 +5038,7 @@ USA.
          create-thread-continuation
          current-thread
          deregister-all-events
+         deregister-gc-event
          deregister-io-descriptor-events
          deregister-io-thread-event
          deregister-subprocess-event
@@ -5045,9 +5050,11 @@ USA.
          make-thread-mutex
          other-running-threads?
          permanently-register-io-thread-event
+         register-gc-event
          register-io-thread-event
          register-subprocess-event
          register-timer-event
+         registered-gc-event
          restart-thread
          set-thread-timer-interval!
          signal-thread-event

diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 26b0d96b48fcf5b8719d82ba6cfe52e809e9a59e..82bfab33d54ec285efefb4c90977af99de8c54e2 100644 (file)
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -914,6 +914,61 @@ USA.
             (maybe-signal-io-thread-events))))
      (%maybe-toggle-thread-timer))))
 \f
+;;;; GC Events
+
+(define gc-events '())                 ;Weak alist of threads X events.
+
+(define (register-gc-event event)
+  (guarantee-procedure-of-arity event 1 'register-gc-event)
+  (without-interrupts
+   (lambda ()
+     (let* ((thread first-running-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)
+  (without-interrupts
+   (lambda ()
+     (let ((entry (weak-assq first-running-thread gc-events)))
+       (if entry
+          (set! gc-events (delq! entry gc-events)))))))
+
+(define (registered-gc-event)
+  (without-interrupts
+   (lambda ()
+     (let ((entry (weak-assq first-running-thread gc-events)))
+       (and entry (weak-cdr entry))))))
+
+(define (signal-gc-events statistic)
+  (without-interrupts
+   (lambda ()
+     (set! gc-events (filter! weak-car gc-events))
+     (for-each
+       (lambda (entry)
+        (let ((thread (weak-car entry)))
+          (if (and thread
+                   (not (eq? 'DEAD (thread/execution-state thread))))
+              (let ((event (weak-cdr entry)))
+                (%signal-thread-event
+                 thread (named-lambda (gc-event)
+                          (abort-if-heap-low
+                           (gc-statistic/heap-left statistic))
+                          (event statistic)))))))
+       gc-events)
+     (%maybe-toggle-thread-timer))))
+
+(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)))
+\f
 ;;;; Subprocess Events
 
 (define subprocess-registrations)