(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!)
(register-gc-event outside)
(deregister-gc-event))
(set! outside)))))
+\f
+;;;; 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)))
+\f
+;;;; Output
(define (gc-notification statistic)
(print-statistic statistic (notification-output-port)))
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)
(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)
create-thread-continuation
current-thread
deregister-all-events
- deregister-gc-event
deregister-io-descriptor-events
deregister-io-thread-event
deregister-timer-event
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
(if subprocess-support-loaded?
(deregister-subprocess-events thread)))
\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)
- (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)))
-\f
;;;; Timer Events
(define timer-records)
projects / mit-scheme.git / commitdiff