suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: fix more problems with GC in an arbitrary Scheme thread

Browse Source
This commit is contained in:
Matthew Flatt 2018-09-13 10:47:31 -06:00
parent 4a763c72d0
commit 9772c05040
4 changed files with 96 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
racket/src/cs/main.sps
View File

@ -411,10 +411,10 @@
(set! minor-gcs (add1 minor-gcs))
(set! major-gcs (add1 major-gcs)))
(set! peak-mem (max peak-mem pre-allocated))
(let ([debug-GC? (log-level? root-logger 'debug 'GC)])
(let ([debug-GC? (log-level?* root-logger 'debug 'GC)])
(when (or debug-GC?
(and (not minor?)
(log-level? root-logger 'debug 'GC:major)))
(log-level?* root-logger 'debug 'GC:major)))
(let ([delta (- pre-allocated post-allocated)])
(log-message* root-logger 'debug (if debug-GC? 'GC 'GC:major)
(chez:format "GC: 0:~a~a @ ~a(~a); free ~a(~a) ~ams @ ~a"

39
racket/src/cs/rumble/error.ss
View File

@ -495,6 +495,45 @@
(lambda (slow-k l)
l)))
(define (continuation->trace* k)
(call-with-values
(lambda ()
(let loop ([k k] [slow-k k] [move? #f])
(cond
[(or (not (#%$continuation? k))
(eq? k #%$null-continuation))
(values slow-k '())]
[else
(let* ([name (or (let ([n #f])
(and n
(string->symbol (format "body of ~a" n))))
(let* ([c (#%$continuation-return-code k)]
[n (#%$code-name c)])
n))]
[desc
(let* ([ci (#%$code-info (#%$continuation-return-code k))]
[src (and
(code-info? ci)
(or
;; when per-expression inspector info is available:
(find-rpi (#%$continuation-return-offset k) (code-info-rpis ci))
;; when only per-function source location is available:
(code-info-src ci)))])
(and (or name src)
(cons name src)))])
(#%$split-continuation k 0)
(call-with-values
(lambda () (loop (#%$continuation-link k) (if move? (#%$continuation-link slow-k) slow-k) (not move?)))
(lambda (slow-k l)
(let ([l (if desc
(cons desc l)
l)])
(when (eq? k slow-k)
(hashtable-set! cached-traces k l))
(values slow-k l)))))])))
(lambda (slow-k l)
l)))
(define (traces->context ls)
(let loop ([l '()] [ls ls])
(cond

60
racket/src/io/logger/main.rkt
View File

@ -11,12 +11,13 @@
logger-name
current-logger
make-logger
log-level? ; ok to call in host-Scheme interrupt handler
log-level?
log-level?* ; ok to call in host-Scheme interrupt handler
log-max-level
log-all-levels
log-level-evt
log-message
log-message* ; ok to call in host-Scheme interrupt handler
log-message* ; ok to call in host-Scheme interrupt handler
log-receiver?
make-log-receiver
add-stderr-log-receiver!
@ -57,12 +58,18 @@
(check who logger? logger)
(check-level who level)
(check who #:or-false symbol? topic)
(atomically/no-interrupts/no-wind
(log-level?* logger level topic)))
;; In atomic mode with interrupts disabled
(define/who (log-level?* logger level topic)
(level>=? (logger-wanted-level logger topic) level))
(define/who (log-max-level logger [topic #f])
(check who logger? logger)
(check who #:or-false symbol? topic)
(logger-wanted-level logger topic))
(atomically/no-interrupts/no-wind
(logger-wanted-level logger topic)))
(define/who (log-all-levels logger)
(check who logger? logger)
@ -106,30 +113,31 @@
(check-level who level)
(check who #:or-false symbol? topic)
(check who string? message)
(log-message* logger level topic message data prefix? #f))
(atomically/no-interrupts/no-wind
(log-message* logger level topic message data prefix? #f)))
;; In atomic mode with interrupts disabled
;; Can be called in any host Scheme thread and in interrupt handler,
;; like `log-level?`:
;; like `log-level?*`
(define (log-message* logger level topic message data prefix? in-interrupt?)
(define msg #f)
(atomically/no-interrupts/no-wind
(when ((logger-max-wanted-level logger) . level>=? . level)
(let loop ([logger logger])
(for ([r (in-list (logger-receivers logger))])
(when ((filters-level-for-topic (log-receiver-filters r) topic) . level>=? . level)
(unless msg
(set! msg (vector-immutable
level
(string->immutable-string
(if (and prefix? topic)
(string-append (symbol->string topic)
": "
message)
message))
data
topic)))
(log-receiver-send! r msg in-interrupt?)))
(let ([parent (logger-parent logger)])
(when (and parent
((filters-level-for-topic (logger-propagate-filters logger) topic) . level>=? . level))
(loop parent)))))))
(when ((logger-max-wanted-level logger) . level>=? . level)
(let loop ([logger logger])
(for ([r (in-list (logger-receivers logger))])
(when ((filters-level-for-topic (log-receiver-filters r) topic) . level>=? . level)
(unless msg
(set! msg (vector-immutable
level
(string->immutable-string
(if (and prefix? topic)
(string-append (symbol->string topic)
": "
message)
message))
data
topic)))
(log-receiver-send! r msg in-interrupt?)))
(let ([parent (logger-parent logger)])
(when (and parent
((filters-level-for-topic (logger-propagate-filters logger) topic) . level>=? . level))
(loop parent))))))

42
racket/src/io/logger/wanted.rkt
View File

@ -4,31 +4,31 @@
"receiver.rkt"
"level.rkt")
(provide logger-wanted-level
(provide logger-wanted-level ; ok to call in host-Scheme interrupt handler
logger-max-wanted-level
logger-all-levels)
;; in atomic mode with interrupts disabled
(define (logger-wanted-level logger topic)
(atomically/no-interrupts/no-wind
(cond
[(not topic) (logger-max-wanted-level logger)]
[else
(cond
[((logger-local-level-timestamp logger) . >= . (unbox (logger-root-level-timestamp-box logger)))
;; Cache is up-to-date, so search it
(define cache (logger-topic-level-cache logger))
(or (for/or ([i (in-range 0 (vector-length cache) 2)])
(and (eq? (vector-ref cache i) topic)
(vector-ref cache (add1 i))))
;; Didn't find in cache, so update the cache
(begin
(update-logger-wanted-level! logger topic)
(logger-wanted-level logger topic)))]
[else
;; Update the cache and retry:
(update-logger-wanted-level! logger topic)
(logger-wanted-level logger topic)])])))
(cond
[(not topic) (logger-max-wanted-level logger)]
[else
(cond
[((logger-local-level-timestamp logger) . >= . (unbox (logger-root-level-timestamp-box logger)))
;; Cache is up-to-date, so search it
(define cache (logger-topic-level-cache logger))
(or (for/or ([i (in-range 0 (vector-length cache) 2)])
(and (eq? (vector-ref cache i) topic)
(vector-ref cache (add1 i))))
;; Didn't find in cache, so update the cache
(begin
(update-logger-wanted-level! logger topic)
(logger-wanted-level logger topic)))]
[else
;; Update the cache and retry:
(update-logger-wanted-level! logger topic)
(logger-wanted-level logger topic)])]))
(define (logger-max-wanted-level logger)
(atomically/no-interrupts/no-wind
(cond