From eb9d34ad5f20de583c3097ba8deebf1c8d99b9ab Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Sun, 5 Jul 2015 09:31:11 -0700 Subject: [PATCH] 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. --- src/runtime/gc.scm | 8 +++--- src/runtime/gcnote.scm | 40 ++++++++++++++++++------------ src/runtime/gcstat.scm | 9 +++---- src/runtime/make.scm | 1 + src/runtime/runtime.pkg | 11 +++++++-- src/runtime/thread.scm | 55 +++++++++++++++++++++++++++++++++++++++++ 6 files changed, 97 insertions(+), 27 deletions(-) diff --git a/src/runtime/gc.scm b/src/runtime/gc.scm index 6693fcc60..1084fc5b5 100644 --- 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 6c3357600..5388bc5a3 100644 --- a/src/runtime/gcnote.scm +++ b/src/runtime/gcnote.scm @@ -29,30 +29,38 @@ USA. (declare (usual-integrations)) +(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 c9c25b300..48208525e 100644 --- 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)) 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 f7841a185..1fd7fa244 100644 --- 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 26b0d96b4..82bfab33d 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -914,6 +914,61 @@ USA. (maybe-signal-io-thread-events)))) (%maybe-toggle-thread-timer)))) +;;;; 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))) + ;;;; Subprocess Events (define subprocess-registrations) -- 2.25.1