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

Don't compute the logs if no-one's reading the logs.

Browse Source
This commit is contained in:
Vincent St-Amour 2012-02-09 16:39:48 -05:00
parent e134e7cd38
commit 4b84e56fa6
1 changed files with 55 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

102
collects/typed-racket/optimizer/logging.rkt
View File

@ -14,6 +14,12 @@
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
(define TR-logging-level 'debug)
;; producing logs can be expensive, don't do it if no-one's listening
;; to the logs
(define (anyone-listening?) (log-level? (current-logger) TR-logging-level))
;; to identify log messages that come from the optimizer ;; to identify log messages that come from the optimizer
;; to be stored in the data section of log messages ;; to be stored in the data section of log messages
;; external tools/scripts (like the test harness) can look for it ;; external tools/scripts (like the test harness) can look for it
@ -32,10 +38,11 @@
(define (log-optimization kind msg stx) (define (log-optimization kind msg stx)
(let ([new-entry (when (anyone-listening?)
(opt-log-entry kind msg (let ([new-entry
stx (locate-stx stx) (syntax-position stx))]) (opt-log-entry kind msg
(set! log-so-far (cons new-entry log-so-far)))) stx (locate-stx stx) (syntax-position stx))])
(set! log-so-far (cons new-entry log-so-far)))))
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
@ -95,47 +102,48 @@
;; Attempts to merge the incoming missed optimization with existing ones. ;; Attempts to merge the incoming missed optimization with existing ones.
;; Otherwise, adds the new one to the log. ;; Otherwise, adds the new one to the log.
(define (log-missed-optimization kind msg stx [irritants '()]) (define (log-missed-optimization kind msg stx [irritants '()])
(let* (;; for convenience, if a single irritant is given, wrap it in a list (when (anyone-listening?)
;; implicitly (let* (;; for convenience, if a single irritant is given, wrap it in a list
[irritants (if (list? irritants) irritants (list irritants))] ;; implicitly
[new [irritants (if (list? irritants) irritants (list irritants))]
(missed-opt-log-entry kind msg [new
stx (locate-stx stx) (syntax-position stx) (missed-opt-log-entry kind msg
irritants '() 1)] stx (locate-stx stx) (syntax-position stx)
;; check if the new one is the child of an old one irritants '() 1)]
;; for/first is ok, since we can only have one parent in the list ;; check if the new one is the child of an old one
;; (if we had more, one would have to be the parent of the other, so ;; for/first is ok, since we can only have one parent in the list
;; only one would be in the list) ;; (if we had more, one would have to be the parent of the other, so
[parent (for/first ([m (in-list missed-optimizations-log)] ;; only one would be in the list)
#:when (parent-of? m new)) [parent (for/first ([m (in-list missed-optimizations-log)]
m)] #:when (parent-of? m new))
;; do we have children in the list, if so, merge with all of them m)]
[children (for/list ([m (in-list missed-optimizations-log)] ;; do we have children in the list, if so, merge with all of them
#:when (parent-of? new m)) [children (for/list ([m (in-list missed-optimizations-log)]
m)]) #:when (parent-of? new m))
;; update m)])
(set! missed-optimizations-log ;; update
(cond [parent (set! missed-optimizations-log
;; we found our parent, merge with it (cond [parent
(if (member (log-entry-stx new) ;; we found our parent, merge with it
(missed-opt-log-entry-merged-irritants (if (member (log-entry-stx new)
parent)) (missed-opt-log-entry-merged-irritants
;; we have been merged in the past, do nothing parent))
missed-optimizations-log ;; we have been merged in the past, do nothing
;; do the actual merge missed-optimizations-log
(cons (combine-missed-optimizations parent new) ;; do the actual merge
(remove parent missed-optimizations-log)))] (cons (combine-missed-optimizations parent new)
[(not (null? children)) (remove parent missed-optimizations-log)))]
;; we found children, merge with them [(not (null? children))
(let ([new (for/fold ([new new]) ;; we found children, merge with them
([child children]) (let ([new (for/fold ([new new])
(combine-missed-optimizations new child))]) ([child children])
(cons new (combine-missed-optimizations new child))])
(filter (lambda (x) (not (member x children))) (cons new
missed-optimizations-log)))] (filter (lambda (x) (not (member x children)))
[else missed-optimizations-log)))]
;; no related entry, just add the new one [else
(cons new missed-optimizations-log)])))) ;; no related entry, just add the new one
(cons new missed-optimizations-log)])))))
;; When we know all missed opts are known and merging has been done, we ;; When we know all missed opts are known and merging has been done, we
;; can add them to the regular log. ;; can add them to the regular log.
@ -195,7 +203,7 @@
(define logger (current-logger)) (define logger (current-logger))
(add-missed-opts-to-log) (add-missed-opts-to-log)
(for ([x (in-list log-so-far)]) (for ([x (in-list log-so-far)])
(log-message logger 'debug (log-message logger TR-logging-level
(format-log-entry x) (format-log-entry x)
(cons optimization-log-key x)))) (cons optimization-log-key x))))
@ -213,7 +221,7 @@
;; only intercepts TR log messages ;; only intercepts TR log messages
(define (with-intercepted-tr-logging interceptor thunk) (define (with-intercepted-tr-logging interceptor thunk)
(with-intercepted-logging (with-intercepted-logging
#:level 'debug #:level TR-logging-level
(lambda (l) ;; look only for optimizer messages (lambda (l) ;; look only for optimizer messages
(when (log-message-from-tr-opt? l) (when (log-message-from-tr-opt? l)
(interceptor l))) (interceptor l)))