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

io: fix logger bugs

Browse Source
This commit is contained in:
Matthew Flatt 2019-01-13 21:03:46 -07:00
parent 0602c7e21b
commit 2fe5f40dd7
5 changed files with 67 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
racket/src/io/logger/level.rkt
View File

@ -7,7 +7,8 @@
level-min
parse-filters
filters-level-for-topic
filters-max-level)
filters-max-level
level->user-representation)
;; A filter set is represented as an improper list of pairs ending
;; with a (non-pair) level symbol. The ending symbol is the level that
@ -87,3 +88,10 @@
(level-max best-level (cdar filters)))]
[else
(level-max best-level filters)])))
;; ----------------------------------------
(define (level->user-representation lvl)
(if (eq? lvl 'none)
#f
lvl))

6
racket/src/io/logger/logger.rkt
View File

@ -16,7 +16,7 @@
topic-level-cache ; topic -> level cache
[local-level-timestamp #:mutable] ; integer
root-level-timestamp-box ; box of integer
[level-sema #:mutable])) ; to report when a receiver is added
level-sema-box)) ; box for sema to report when a receiver is added
(define/who (logger-name logger)
(check who logger? logger)
@ -35,7 +35,9 @@
(if parent
(logger-root-level-timestamp-box parent)
(box 0))
#f)) ; level-sema
(if parent
(logger-level-sema-box parent)
(box #f))))
;; Get log receivers, dropping any boxes made empty due to a weak
;; reference:

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

@ -68,8 +68,9 @@
(define/who (log-max-level logger [topic #f])
(check who logger? logger)
(check who #:or-false symbol? topic)
(atomically/no-interrupts/no-wind
(logger-wanted-level logger topic)))
(level->user-representation
(atomically/no-interrupts/no-wind
(logger-wanted-level logger topic))))
(define/who (log-all-levels logger)
(check who logger? logger)
@ -80,11 +81,11 @@
(define s
(atomically
(cond
[(logger-level-sema logger)
[(unbox (logger-level-sema-box logger))
=> (lambda (s) s)]
[else
(define s (make-semaphore))
(set-logger-level-sema! logger s)
(set-box! (logger-level-sema-box logger) s)
s])))
(semaphore-peek-evt s))

20
racket/src/io/logger/receiver.rkt
View File

@ -12,7 +12,8 @@
make-log-receiver
add-stderr-log-receiver!
add-stdout-log-receiver!
log-receiver-send!)
log-receiver-send!
receiver-add-topics)
(struct log-receiver (filters))
@ -144,9 +145,10 @@
(set-box! ts-box (add1 (unbox ts-box)))
;; Post a semaphore to report that wanted levels may have
;; changed:
(when (logger-level-sema logger)
(semaphore-post (logger-level-sema logger))
(set-logger-level-sema! logger #f))))
(define sema-box (logger-level-sema-box logger))
(when (unbox sema-box)
(semaphore-post (unbox sema-box))
(set-box! sema-box #f))))
;; Called in atomic mode and with interrupts disabled
(define (log-receiver-send! r msg in-interrupt?)
@ -157,3 +159,13 @@
;; Record any any other message for posting later:
(unsafe-add-pre-poll-callback! (lambda ()
((receiver-send-ref r) r msg)))))
;; ----------------------------------------
(define (receiver-add-topics r topics default-level)
(let loop ([filters (log-receiver-filters r)] [topics topics])
(cond
[(pair? filters)
(loop (cdr filters) (hash-set topics (caar filters) #t))]
[else
(values topics (level-max default-level filters))])))

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

@ -33,7 +33,7 @@
(atomically/no-interrupts/no-wind
(cond
[((logger-local-level-timestamp logger) . >= . (unbox (logger-root-level-timestamp-box logger)))
;; Ccahed value is up-to-date
;; Cached value is up-to-date
(logger-max-receiver-level logger)]
[else
;; Traverse to set cache:
@ -49,7 +49,7 @@
;; As we traverse the parent chain, keep track of the "ceiling"
;; level as the maximum level that would be propagated; for any
;; receiver, clip the wanted levels to that ceiling.
(let loop ([parent logger] [ceiling-level 'debug] [old-max-level 'none] [old-topic-max-level 'none])
(let loop ([parent logger] [ceiling-level 'debug] [old-max-level 'none] [topic-ceiling-level 'debug] [old-topic-max-level 'none])
(define-values (max-level topic-max-level)
(for/fold ([max-level old-max-level] [topic-max-level old-topic-max-level])
([r (in-list (logger-receivers parent))]
@ -62,14 +62,19 @@
(and topic
(level-max topic-max-level
(level-min (filters-level-for-topic (log-receiver-filters r) topic)
ceiling-level))))))
topic-ceiling-level))))))
(cond
[(and (or (ceiling-level . level>=? . max-level)
(and topic (ceiling-level . level>=? . topic-max-level)))
(logger-parent parent))
=> (lambda (next-parent)
(let ([ceiling-level (level-min ceiling-level (filters-max-level (logger-propagate-filters parent)))])
(loop next-parent ceiling-level max-level topic-max-level)))]
(define filters (logger-propagate-filters parent))
(let ([ceiling-level (level-min ceiling-level (filters-max-level filters))]
[topic-ceiling-level (if topic
(level-min topic-ceiling-level
(filters-level-for-topic filters topic))
topic-ceiling-level)])
(loop next-parent ceiling-level max-level topic-ceiling-level topic-max-level)))]
[else
;; No more parents, so save the result
(set-logger-max-receiver-level! logger max-level)
@ -93,4 +98,26 @@
(define (logger-all-levels logger)
'(none #f))
(define-values (topics default-level)
(let loop ([topics #hasheq()] [default-level 'none] [max-default-level 'debug] [logger logger])
(define-values (new-topics new-default-level)
(for*/fold ([topics topics] [default-level 'none]) ([r (in-list (logger-receivers logger))])
(receiver-add-topics r topics default-level)))
(define next-default-level (level-max (level-min new-default-level max-default-level)
default-level))
(define parent-logger (logger-parent logger))
(if parent-logger
(let ([max-default-level (level-min max-default-level
(filters-level-for-topic
(logger-propagate-filters logger)
#f))])
(loop new-topics next-default-level max-default-level parent-logger))
(values new-topics next-default-level))))
(list* (level->user-representation default-level) #f
(apply
append
(for/list ([topic (in-hash-keys topics)])
(list (level->user-representation
(atomically/no-interrupts/no-wind
(logger-wanted-level logger topic)))
topic)))))