From 9772c05040e64ea3e94a48a4a53bff66bc5691ba Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 13 Sep 2018 10:47:31 -0600 Subject: [PATCH] cs: fix more problems with GC in an arbitrary Scheme thread --- racket/src/cs/main.sps | 4 +-- racket/src/cs/rumble/error.ss | 39 +++++++++++++++++++++ racket/src/io/logger/main.rkt | 60 +++++++++++++++++++-------------- racket/src/io/logger/wanted.rkt | 42 +++++++++++------------ 4 files changed, 96 insertions(+), 49 deletions(-) diff --git a/racket/src/cs/main.sps b/racket/src/cs/main.sps index ffeb728749..b073c1e166 100644 --- a/racket/src/cs/main.sps +++ b/racket/src/cs/main.sps @@ -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" diff --git a/racket/src/cs/rumble/error.ss b/racket/src/cs/rumble/error.ss index 1d3aead465..7ee36cf7d4 100644 --- a/racket/src/cs/rumble/error.ss +++ b/racket/src/cs/rumble/error.ss @@ -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 diff --git a/racket/src/io/logger/main.rkt b/racket/src/io/logger/main.rkt index 9656be25e7..7b7a911e02 100644 --- a/racket/src/io/logger/main.rkt +++ b/racket/src/io/logger/main.rkt @@ -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)))))) diff --git a/racket/src/io/logger/wanted.rkt b/racket/src/io/logger/wanted.rkt index 733e97fb88..1dad94adf2 100644 --- a/racket/src/io/logger/wanted.rkt +++ b/racket/src/io/logger/wanted.rkt @@ -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