From: Matt Birkholz Date: Sun, 12 Jul 2015 01:13:00 +0000 (-0700) Subject: Move GC event support to runtime/gcnote.scm. X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=52cec1ca0c131c17ded5631b235d799f35964306;p=mit-scheme.git Move GC event support to runtime/gcnote.scm. --- diff --git a/src/runtime/gcnote.scm b/src/runtime/gcnote.scm index 5388bc5a3..eb4f3b2bf 100644 --- a/src/runtime/gcnote.scm +++ b/src/runtime/gcnote.scm @@ -30,8 +30,6 @@ 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!) @@ -61,6 +59,86 @@ USA. (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 statistic) + ;; This procedure runs atomically(!), with absolutely no interrupts + ;; and all other processors in the GC-WAIT state. It may interrupt + ;; the procedures holding the gc-events-mutex, but it does not + ;; modify the list. + (with-thread-lock + (lambda () + (for-each + (lambda (entry) + (let ((thread (weak-car entry)) + (event (weak-cdr entry))) + (if (and thread + event + (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) + (%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))) + +;;;; Output (define (gc-notification statistic) (print-statistic statistic (notification-output-port))) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 32fa8af5e..94b234507 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1970,7 +1970,7 @@ USA. hook/gc-start) (export (runtime error-handler) hook/hardware-trap) - (export (runtime thread) + (export (runtime gc-notification) abort-if-heap-low) (import (runtime thread) with-gc-lock) @@ -2009,14 +2009,22 @@ USA. (define-package (runtime gc-notification) (files "gcnote") (parent (runtime)) - (export (runtime thread) - signal-gc-events) (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!) + (export (runtime thread) + %deregister-gc-event) + (import (runtime thread) + %maybe-toggle-thread-timer + %signal-thread-event + thread/execution-state + with-thread-lock) (initialization (initialize-package!))) (define-package (runtime gc-statistics) @@ -5057,7 +5065,6 @@ USA. create-thread-continuation current-thread deregister-all-events - deregister-gc-event deregister-io-descriptor-events deregister-io-thread-event deregister-timer-event @@ -5069,10 +5076,8 @@ USA. make-thread-mutex other-running-threads? permanently-register-io-thread-event - register-gc-event register-io-thread-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 f0d76ac79..5854220fe 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -1069,65 +1069,6 @@ USA. (if subprocess-support-loaded? (deregister-subprocess-events thread))) -;;;; 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) - (with-thread-lock - (lambda () - (let* ((thread (%thread (%id))) - (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-lock - (lambda () - (%deregister-gc-event (%thread (%id)))))) - -(define (%deregister-gc-event thread) - (%assert-locked '%deregister-gc-event) - (let ((entry (weak-assq thread gc-events))) - (if entry - (set! gc-events (delq! entry gc-events))))) - -(define (registered-gc-event) - (with-thread-lock - (lambda () - (let ((entry (weak-assq (%thread (%id)) gc-events))) - (and entry (weak-cdr entry)))))) - -(define (signal-gc-events statistic) - (with-thread-lock - (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))) - ;;;; Timer Events (define timer-records)