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

Abstract out printing of missed optimization log messages.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-06-03 16:19:33 -04:00
parent 4c31b08554
commit c5ca1422a2
1 changed files with 19 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
collects/typed-scheme/optimizer/logging.rkt
View File

@ -47,7 +47,7 @@
(define (print-log) (define (print-log)
(define logger (current-logger)) (define logger (current-logger))
;; add missed optimizations messages to the log, now that we know all of them ;; add missed optimizations messages to the log, now that we know all of them
(for-each (lambda (x) (do-logging (missed-optimization-msg x) (for-each (lambda (x) (do-logging (format-missed-optimization x)
(missed-optimization-stx x))) (missed-optimization-stx x)))
missed-optimizations-log) missed-optimizations-log)
(for-each (lambda (x) (log-message logger 'warning (log-entry-msg x) (for-each (lambda (x) (log-message logger 'warning (log-entry-msg x)
@ -87,7 +87,7 @@
;; badness : Integer. crude measure of how severe the missed optimizations are ;; badness : Integer. crude measure of how severe the missed optimizations are
;; currently, it's simply a count of how many missed optimizations occur ;; currently, it's simply a count of how many missed optimizations occur
;; within a given syntax object ;; within a given syntax object
(struct missed-optimization (msg stx irritants [badness #:mutable]) (struct missed-optimization (kind stx irritants [badness #:mutable])
#:transparent) #:transparent)
(define missed-optimizations-log '()) (define missed-optimizations-log '())
@ -95,18 +95,22 @@
(define (log-missed-optimization kind stx [irritants '()]) (define (log-missed-optimization kind stx [irritants '()])
;; for convenience, if a single irritant is given, wrap it in a list ;; for convenience, if a single irritant is given, wrap it in a list
;; implicitly ;; implicitly
(let* ([irritants (if (list? irritants) irritants (list irritants))] (let ([irritants (if (list? irritants) irritants (list irritants))])
[msg (if (not (null? irritants))
(format "~a -- caused by: ~a"
kind
(string-join
(map (lambda (irritant)
(format "~a ~a"
(line+col->string irritant)
(syntax->datum irritant)))
irritants)
", "))
kind)])
(set! missed-optimizations-log (set! missed-optimizations-log
(cons (missed-optimization msg stx irritants 1) (cons (missed-optimization kind stx irritants 1)
missed-optimizations-log)))) missed-optimizations-log))))
(define (format-missed-optimization m)
(let ([kind (missed-optimization-kind m)]
[irritants (missed-optimization-irritants m)])
(if (not (null? irritants))
(format "~a -- caused by: ~a"
kind
(string-join
(map (lambda (irritant)
(format "~a ~a"
(line+col->string irritant)
(syntax->datum irritant)))
irritants)
", "))
kind)))