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

Put logging code in its own file.

Browse Source 
original commit: 4c31b085546f5e4c6f20982b805fcebd6c6bb5ba
This commit is contained in:
Vincent St-Amour 2011-06-03 16:04:26 -04:00
parent 1621df5042
commit 2151a7edc0
17 changed files with 131 additions and 125 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/tests/typed-scheme/optimizer/run.rkt
View File

@ -1,7 +1,7 @@
#lang racket
(require racket/runtime-path
rackunit rackunit/text-ui
typed-scheme/optimizer/utils
typed-scheme/optimizer/logging
unstable/logging)
(provide optimization-tests missed-optimization-tests

2
collects/typed-scheme/optimizer/apply.rkt
View File

@ -2,7 +2,7 @@
(require syntax/parse
(for-template scheme/unsafe/ops racket/base (prefix-in k: '#%kernel))
"../utils/utils.rkt"
(optimizer utils))
(optimizer utils logging))
(provide apply-opt-expr)

2
collects/typed-scheme/optimizer/box.rkt
View File

@ -6,7 +6,7 @@
(for-template scheme/base scheme/unsafe/ops)
(rep type-rep)
(types type-table utils)
(optimizer utils))
(optimizer utils logging))
(provide box-opt-expr)

2
collects/typed-scheme/optimizer/dead-code.rkt
View File

@ -4,7 +4,7 @@
(for-template scheme/base)
"../utils/utils.rkt"
(types type-table)
(optimizer utils))
(optimizer utils logging))
(provide dead-code-opt-expr)

2
collects/typed-scheme/optimizer/fixnum.rkt
View File

@ -4,7 +4,7 @@
"../utils/utils.rkt"
(for-template scheme/base scheme/fixnum scheme/unsafe/ops)
(types numeric-tower)
(optimizer utils))
(optimizer utils logging))
(provide fixnum-expr fixnum-opt-expr)

2
collects/typed-scheme/optimizer/float-complex.rkt
View File

@ -4,7 +4,7 @@
"../utils/utils.rkt" racket/unsafe/ops
(for-template scheme/base scheme/math racket/flonum scheme/unsafe/ops)
(types numeric-tower)
(optimizer utils numeric-utils float))
(optimizer utils numeric-utils logging float))
(provide float-complex-opt-expr
float-complex-arith-opt-expr

2
collects/typed-scheme/optimizer/float.rkt
View File

@ -5,7 +5,7 @@
(for-template racket/base racket/flonum racket/unsafe/ops racket/math)
"../utils/utils.rkt"
(types numeric-tower)
(optimizer utils numeric-utils fixnum))
(optimizer utils numeric-utils logging fixnum))
(provide float-opt-expr float-arg-expr)

112
collects/typed-scheme/optimizer/logging.rkt Normal file
View File

@ -0,0 +1,112 @@
#lang racket/base
(require racket/set racket/string racket/match
unstable/syntax)
(provide log-optimization log-missed-optimization
optimization-log-key
print-log clear-log)
(define (line+col->string stx)
(let ([line (syntax-line stx)]
[col (syntax-column stx)])
(if (and line col)
(format "~a:~a" line col)
"(no location)")))
(struct log-entry (msg line col) #:transparent)
;; to identify log messages that come from the optimizer
;; to be stored in the data section of log messages
;; external tools/scripts (like the test harness) can look for it
;; since this is used across phases, can't be a gensym
(define optimization-log-key 'log-message-coming-from-the-TR-optimizer)
;; we keep track of log entries, to avoid repetitions that would be
;; caused by traversing the same syntax multiple times (which is not
;; a problem per se)
(define log-so-far (set))
(define (gen-log-message msg stx)
(format "~a ~a ~a -- ~a"
(syntax-source-file-name stx)
(line+col->string stx)
(syntax->datum stx)
msg))
(define (do-logging msg stx)
(let* ([new-message (gen-log-message msg stx)]
[new-entry (log-entry new-message
(syntax-line stx)
(syntax-column stx))])
(unless (set-member? log-so-far new-entry)
(set! log-so-far (set-add log-so-far new-entry)))))
;; once the optimizer is done, we sort the log according to source
;; location, then print it
(define (print-log)
(define logger (current-logger))
;; add missed optimizations messages to the log, now that we know all of them
(for-each (lambda (x) (do-logging (missed-optimization-msg x)
(missed-optimization-stx x)))
missed-optimizations-log)
(for-each (lambda (x) (log-message logger 'warning (log-entry-msg x)
optimization-log-key))
(sort (set->list log-so-far)
(lambda (x y)
(match* (x y)
[((log-entry msg-x line-x col-x)
(log-entry msg-y line-y col-y))
(cond [(not (or line-x line-y))
;; neither have location, sort by message
(string<? msg-x msg-y)]
[(not line-y) #f]
[(not line-x) #t]
[else
;; both have location
(let* ([loc-x (+ (* 1000 line-x) col-x)]
;; 1000 is a conservative bound
[loc-y (+ (* 1000 line-y) col-y)])
(cond [(= loc-x loc-y)
;; same location, sort by message
(string<? msg-x msg-y)]
;; sort by source location
[else (< loc-x loc-y)]))])])))))
(define (clear-log)
(set! log-so-far (set))
(set! missed-optimizations-log '()))
(define (log-optimization kind stx) (do-logging kind stx))
;; Keep track of optimizations that "almost" happened, with the intention
;; of reporting them to the user.
;; This is meant to help users understand what hurts the performance of
;; their programs.
;; badness : Integer. crude measure of how severe the missed optimizations are
;; currently, it's simply a count of how many missed optimizations occur
;; within a given syntax object
(struct missed-optimization (msg stx irritants [badness #:mutable])
#:transparent)
(define missed-optimizations-log '())
(define (log-missed-optimization kind stx [irritants '()])
;; for convenience, if a single irritant is given, wrap it in a list
;; implicitly
(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
(cons (missed-optimization msg stx irritants 1)
missed-optimizations-log))))

2
collects/typed-scheme/optimizer/number.rkt
View File

@ -3,7 +3,7 @@
(require syntax/parse
(for-template scheme/base)
"../utils/utils.rkt"
(optimizer utils))
(optimizer utils logging))
(provide number-opt-expr)

5
collects/typed-scheme/optimizer/optimizer.rkt
View File

@ -4,8 +4,9 @@
racket/pretty
(for-template scheme/base)
"../utils/utils.rkt"
(optimizer utils number fixnum float float-complex vector string
pair sequence box struct dead-code apply unboxed-let))
(optimizer utils logging
number fixnum float float-complex vector string pair
sequence box struct dead-code apply unboxed-let))
(provide optimize-top)

2
collects/typed-scheme/optimizer/pair.rkt
View File

@ -7,7 +7,7 @@
(rep type-rep)
(types type-table utils)
(typecheck typechecker)
(optimizer utils))
(optimizer utils logging))
(provide pair-opt-expr)

2
collects/typed-scheme/optimizer/sequence.rkt
View File

@ -6,7 +6,7 @@
"../utils/utils.rkt" "../utils/tc-utils.rkt"
(rep type-rep)
(types abbrev type-table utils)
(optimizer utils string))
(optimizer utils logging string))
(provide sequence-opt-expr)

2
collects/typed-scheme/optimizer/string.rkt
View File

@ -4,7 +4,7 @@
(for-template scheme/base scheme/unsafe/ops)
"../utils/utils.rkt"
(types abbrev)
(optimizer utils))
(optimizer utils logging))
(provide string-opt-expr string-expr bytes-expr)

2
collects/typed-scheme/optimizer/struct.rkt
View File

@ -4,7 +4,7 @@
(for-template scheme/base scheme/unsafe/ops)
"../utils/utils.rkt"
(types type-table)
(optimizer utils))
(optimizer utils logging))
(provide struct-opt-expr)

2
collects/typed-scheme/optimizer/unboxed-let.rkt
View File

@ -7,7 +7,7 @@
(for-template scheme/base)
(types numeric-tower utils type-table)
(rep type-rep)
(optimizer utils float-complex))
(optimizer utils logging float-complex))
(provide unboxed-let-opt-expr)

111
collects/typed-scheme/optimizer/utils.rkt
View File

@ -1,126 +1,19 @@
#lang racket/base
(require unstable/match racket/match racket/set racket/string
(require unstable/match racket/match
racket/dict syntax/id-table racket/syntax unstable/syntax
"../utils/utils.rkt"
(for-template racket/base)
(types type-table utils subtype)
(rep type-rep))
(provide log-optimization log-missed-optimization
optimization-log-key
print-log clear-log
*show-optimized-code*
(provide *show-optimized-code*
subtypeof? isoftype?
mk-unsafe-tbl
n-ary->binary
unboxed-gensym reset-unboxed-gensym
optimize)
(define (line+col->string stx)
(let ([line (syntax-line stx)]
[col (syntax-column stx)])
(if (and line col)
(format "~a:~a" line col)
"(no location)")))
(struct log-entry (msg line col) #:transparent)
;; to identify log messages that come from the optimizer
;; to be stored in the data section of log messages
;; external tools/scripts (like the test harness) can look for it
;; since this is used across phases, can't be a gensym
(define optimization-log-key 'log-message-coming-from-the-TR-optimizer)
;; we keep track of log entries, to avoid repetitions that would be
;; caused by traversing the same syntax multiple times (which is not
;; a problem per se)
(define log-so-far (set))
(define (gen-log-message msg stx)
(format "~a ~a ~a -- ~a"
(syntax-source-file-name stx)
(line+col->string stx)
(syntax->datum stx)
msg))
(define (do-logging msg stx)
(let* ([new-message (gen-log-message msg stx)]
[new-entry (log-entry new-message
(syntax-line stx)
(syntax-column stx))])
(unless (set-member? log-so-far new-entry)
(set! log-so-far (set-add log-so-far new-entry)))))
;; once the optimizer is done, we sort the log according to source
;; location, then print it
(define (print-log)
(define logger (current-logger))
;; add missed optimizations messages to the log, now that we know all of them
(for-each (lambda (x) (do-logging (missed-optimization-msg x)
(missed-optimization-stx x)))
missed-optimizations-log)
(for-each (lambda (x) (log-message logger 'warning (log-entry-msg x)
optimization-log-key))
(sort (set->list log-so-far)
(lambda (x y)
(match* (x y)
[((log-entry msg-x line-x col-x)
(log-entry msg-y line-y col-y))
(cond [(not (or line-x line-y))
;; neither have location, sort by message
(string<? msg-x msg-y)]
[(not line-y) #f]
[(not line-x) #t]
[else
;; both have location
(let* ([loc-x (+ (* 1000 line-x) col-x)]
;; 1000 is a conservative bound
[loc-y (+ (* 1000 line-y) col-y)])
(cond [(= loc-x loc-y)
;; same location, sort by message
(string<? msg-x msg-y)]
;; sort by source location
[else (< loc-x loc-y)]))])])))))
(define (clear-log)
(set! log-so-far (set))
(set! missed-optimizations-log '()))
(define (log-optimization kind stx) (do-logging kind stx))
;; Keep track of optimizations that "almost" happened, with the intention
;; of reporting them to the user.
;; This is meant to help users understand what hurts the performance of
;; their programs.
;; badness : Integer. crude measure of how severe the missed optimizations are
;; currently, it's simply a count of how many missed optimizations occur
;; within a given syntax object
(struct missed-optimization (msg stx irritants [badness #:mutable])
#:transparent)
(define missed-optimizations-log '())
(define (log-missed-optimization kind stx [irritants '()])
;; for convenience, if a single irritant is given, wrap it in a list
;; implicitly
(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
(cons (missed-optimization msg stx irritants 1)
missed-optimizations-log))))
;; if set to #t, the optimizer will dump its result to stdout before compilation
(define *show-optimized-code* #f)

2
collects/typed-scheme/optimizer/vector.rkt
View File

@ -6,7 +6,7 @@
"../utils/utils.rkt"
(rep type-rep)
(types type-table utils)
(optimizer utils))
(optimizer utils logging))
(provide vector-opt-expr)