#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))))
(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?)
(declare (usual-integrations))
\f
+(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)))))
+\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)
+ (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)))
+\f
+;;;; Output
(define (gc-notification statistic)
(print-statistic statistic (notification-output-port)))
(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!)
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)
(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))
\f
(define timestamp)
(define total-gc-time)
(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))
\f
;; REP Loops
(RUNTIME INTERRUPT-HANDLER)
(RUNTIME GC-STATISTICS)
+ (RUNTIME GC-NOTIFICATION)
(RUNTIME REP)
;; Debugging
(RUNTIME COMPILER-INFO)
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)
(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")
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)
(set-thread/block-events?! thread block?)))
unspecific)))
\f
-(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)
(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)
projects / mit-scheme.git / commitdiff