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! minor-gcs (add1 minor-gcs))
(set! major-gcs (add1 major-gcs))) (set! major-gcs (add1 major-gcs)))
(set! peak-mem (max peak-mem pre-allocated)) (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? (when (or debug-GC?
(and (not minor?) (and (not minor?)
(log-level? root-logger 'debug 'GC:major))) (log-level?* root-logger 'debug 'GC:major)))
(let ([delta (- pre-allocated post-allocated)]) (let ([delta (- pre-allocated post-allocated)])
(log-message* root-logger 'debug (if debug-GC? 'GC 'GC:major) (log-message* root-logger 'debug (if debug-GC? 'GC 'GC:major)
(chez:format "GC: 0:~a~a @ ~a(~a); free ~a(~a) ~ams @ ~a" (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) (lambda (slow-k l)
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) (define (traces->context ls)
(let loop ([l '()] [ls ls]) (let loop ([l '()] [ls ls])
(cond (cond

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

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

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

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