From 1d15962559677b00b0c931131c86e320c393fe87 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Mon, 17 Aug 2015 17:19:15 -0700 Subject: [PATCH] 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. --- src/runtime/gc.scm | 8 +-- src/runtime/gcnote.scm | 111 ++++++++++++++++++++++++++++++++++------ src/runtime/gcstat.scm | 14 ++--- src/runtime/make.scm | 1 + src/runtime/runtime.pkg | 13 +++-- src/runtime/thread.scm | 20 +++++--- 6 files changed, 126 insertions(+), 41 deletions(-) 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) -- 2.25.1