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

Split tool into multiple files.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-07-01 12:32:38 -04:00
parent d3db388c05
commit e736653413
3 changed files with 135 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
collects/typed-scheme/optimizer/tool/display.rkt Normal file
View File

@ -0,0 +1,35 @@
#lang racket/base
(require racket/string racket/pretty racket/class racket/gui/base
unstable/sequence)
(provide format-message make-color-table)
(define (format-message stxs+msgs)
(string-join (for/list ([(stx msg) (in-pairs stxs+msgs)])
(format "~a\n~a"
(pretty-format (syntax->datum stx))
msg))
"\n\n"))
(define lowest-badness-color (make-object color% "pink"))
(define highest-badness-color (make-object color% "red"))
;; the higher the badness, the closer to red the highlight should be
(define (make-color-table max-badness)
(define min-g (send highest-badness-color green))
(define max-g (send lowest-badness-color green))
(define min-b (send highest-badness-color blue))
(define max-b (send lowest-badness-color blue))
(define delta-g (- max-g min-g))
(define delta-b (- max-b min-b))
(define bucket-size-g (quotient delta-g max-badness))
(define bucket-size-b (quotient delta-b max-badness))
(build-vector (add1 max-badness) ; to index directly using badness
(lambda (x)
(make-object
color%
255
;; clipping, since the first (unused, for
;; badness of 0) would have invalid components
(min 255 (- max-g (* (sub1 x) bucket-size-g)))
(min 255 (- max-b (* (sub1 x) bucket-size-b)))))))

96
collects/typed-scheme/optimizer/tool/report.rkt Normal file
View File

@ -0,0 +1,96 @@
#lang racket/base
(require racket/class racket/gui/base racket/match)
(require (prefix-in tr: typed-scheme/typed-reader)
typed-scheme/optimizer/logging)
(provide (struct-out report-entry)
(struct-out opt-report-entry)
(struct-out missed-opt-report-entry)
generate-report)
;; Similar to the log-entry family of structs, but geared towards GUI display.
;; Also designed to contain info for multiple overlapping log entries.
;; stxs+msgs is a list of syntax-message pairs
(struct report-entry (stxs+msgs start end))
(struct opt-report-entry report-entry ())
(struct missed-opt-report-entry report-entry (badness irritants))
(define (generate-report this)
(collapse-report (log->report (generate-log this))))
(define (generate-log this)
(define portname (send this get-port-name))
(define input (open-input-text-editor this))
(port-count-lines! input)
(define log '())
(with-intercepted-tr-logging
(lambda (l)
(set! log (cons (cdr (vector-ref l 2)) ; log-entry struct
log)))
(lambda ()
(parameterize ([current-namespace (make-base-namespace)]
[read-accept-reader #t])
(expand (tr:read-syntax portname input)))))
log)
;; converts log-entry structs to report-entry structs for further
;; processing
(define (log->report log)
(define (log-entry->report-entry l)
(match l
[(log-entry kind msg stx (? number? pos))
(define stxs+msgs `((,stx . ,msg)))
(define start (sub1 pos))
(define end (+ start (syntax-span stx)))
(if (opt-log-entry? l)
(opt-report-entry stxs+msgs start end)
(missed-opt-report-entry stxs+msgs start end
(missed-opt-log-entry-badness l)
(missed-opt-log-entry-irritants l)))]
[_ #f])) ; no source location, ignore
(filter values (map log-entry->report-entry log)))
(define (merge-entries prev l)
(define new-stxs+msgs
(append (report-entry-stxs+msgs prev) (report-entry-stxs+msgs l)))
(match (list prev l)
[`(,(missed-opt-report-entry ss+ms1 start1 end1 bad1 irr1)
,(missed-opt-report-entry ss+ms2 start2 end2 bad2 irr2))
;; we take start1 and end1 since prev includes l
(missed-opt-report-entry new-stxs+msgs start1 end1
(+ bad1 bad2) (append irr1 irr2))]
[(or `(,(missed-opt-report-entry ss+ms1 start1 end1 bad irr)
,(report-entry ss+ms2 start2 end2))
`(,(report-entry ss+ms1 start1 end1)
,(missed-opt-report-entry ss+ms2 start2 end2 bad irr)))
;; since missed opts are more important to report, they win
(missed-opt-report-entry new-stxs+msgs start1 end1 bad irr)]
[`(,(report-entry ss+ms1 start1 end1) ,(report-entry ss+ms2 start2 end2))
;; both are opts
(report-entry new-stxs+msgs start1 end1)]))
;; detect overlapping reports and merge them
(define (collapse-report orig-report)
;; sort in order of starting point
(define report (sort orig-report < #:key report-entry-start))
(define-values (new-report _)
(for/fold ([new-report '()]
[prev #f])
([l (in-list report)])
(match* (prev l)
[((report-entry stxs+msgs1 start1 end1)
(report-entry stxs+msgs2 start2 end2))
(=> unmatch)
(if (< start2 end1) ; l in within prev
;; merge the two
(values (cons (merge-entries prev l) (cdr new-report))
;; we don't advance, since we merged
prev)
(unmatch))]
[(prev l) ; no overlap, just add to the list
(values (cons l new-report) l)])))
new-report)

118
collects/typed-scheme/optimizer/tool/tool.rkt
View File

@ -1,12 +1,9 @@
#lang racket/base
(require racket/class racket/port racket/list racket/match racket/string
racket/gui/base mrlib/switchable-button
racket/unit drracket/tool
unstable/sequence)
(require racket/class racket/port racket/list racket/match
racket/gui/base racket/unit drracket/tool)
(require (prefix-in tr: typed-scheme/typed-reader)
typed-scheme/optimizer/logging)
(require "report.rkt" "display.rkt")
(provide performance-report-drracket-button
tool@)
@ -22,35 +19,6 @@
(define (performance-report-callback drr-frame)
(send (send drr-frame get-definitions-text) add-highlights))
(define lowest-badness-color (make-object color% "pink"))
(define highest-badness-color (make-object color% "red"))
;; the higher the badness, the closer to red the highlight should be
(define (make-color-table max-badness)
(define min-g (send highest-badness-color green))
(define max-g (send lowest-badness-color green))
(define min-b (send highest-badness-color blue))
(define max-b (send lowest-badness-color blue))
(define delta-g (- max-g min-g))
(define delta-b (- max-b min-b))
(define bucket-size-g (quotient delta-g max-badness))
(define bucket-size-b (quotient delta-b max-badness))
(build-vector (add1 max-badness) ; to index directly using badness
(lambda (x)
(make-object
color%
255
;; clipping, since the first (unused, for
;; badness of 0) would have invalid components
(min 255 (- max-g (* (sub1 x) bucket-size-g)))
(min 255 (- max-b (* (sub1 x) bucket-size-b)))))))
;; Similar to the log-entry family of structs, but geared towards GUI display.
;; Also designed to contain info for multiple overlapping log entries.
;; stxs+msgs is a list of syntax-message pairs
(struct report-entry (stxs+msgs start end))
(struct opt-report-entry report-entry ())
(struct missed-opt-report-entry report-entry (badness irritants))
(define highlights-mixin
(mixin ((class->interface text%)) ()
(inherit begin-edit-sequence
@ -75,11 +43,6 @@
;; info needed to remove the highlight
(list start end color caret-space style))))
(define (format-message stxs+msgs)
(string-join (for/list ([(stx msg) (in-pairs stxs+msgs)])
(format "~a\n~a" (syntax->datum stx) msg))
"\n\n"))
(define (highlight-entry l)
(match l
[(report-entry stxs+msgs start end)
@ -102,62 +65,8 @@
(map highlight-irritant
(missed-opt-report-entry-irritants l))))))]))
(define (generate-log)
(define portname (send this get-port-name))
(define input (open-input-text-editor this))
(port-count-lines! input)
(define log '())
(with-intercepted-tr-logging
(lambda (l)
(set! log (cons (cdr (vector-ref l 2)) ; log-entry struct
log)))
(lambda ()
(parameterize ([current-namespace (make-base-namespace)]
[read-accept-reader #t])
(expand (tr:read-syntax portname input)))))
log)
;; converts log-entry structs to report-entry structs for further
;; processing
(define (log->report log)
(define (log-entry->report-entry l)
(match l
[(log-entry kind msg stx (? number? pos))
(define stxs+msgs `((,stx . ,msg)))
(define start (sub1 pos))
(define end (+ start (syntax-span stx)))
(if (opt-log-entry? l)
(opt-report-entry stxs+msgs start end)
(missed-opt-report-entry stxs+msgs start end
(missed-opt-log-entry-badness l)
(missed-opt-log-entry-irritants l)))]
[_ #f])) ; no source location, ignore
(filter values (map log-entry->report-entry log)))
;; detect overlapping reports and merge them
(define (collapse-report orig-report)
;; sort in order of starting point
(define report (sort orig-report < #:key report-entry-start))
(define-values (new-report _)
(for/fold ([new-report '()]
[prev #f])
([l (in-list report)])
(match* (prev l)
[((report-entry stxs+msgs1 start1 end1)
(report-entry stxs+msgs2 start2 end2))
(=> unmatch)
(if (< start2 end1) ; l in within prev
;; merge the two
(values (cons (merge-entries prev l) (cdr new-report))
;; we don't advance, since we merged
prev)
(unmatch))]
[(prev l) ; no overlap, just add to the list
(values (cons l new-report) l)])))
new-report)
(define/public (add-highlights)
(define report (collapse-report (log->report (generate-log))))
(define report (generate-report this))
(define max-badness
(for/fold ([max-badness 0])
([l (in-list report)]
@ -183,25 +92,6 @@
(super-new)))
(define (merge-entries prev l)
(define new-stxs+msgs
(append (report-entry-stxs+msgs prev) (report-entry-stxs+msgs l)))
(match (list prev l)
[`(,(missed-opt-report-entry ss+ms1 start1 end1 bad1 irr1)
,(missed-opt-report-entry ss+ms2 start2 end2 bad2 irr2))
;; we take start1 and end1 since prev includes l
(missed-opt-report-entry new-stxs+msgs start1 end1
(+ bad1 bad2) (append irr1 irr2))]
[(or `(,(missed-opt-report-entry ss+ms1 start1 end1 bad irr)
,(report-entry ss+ms2 start2 end2))
`(,(report-entry ss+ms1 start1 end1)
,(missed-opt-report-entry ss+ms2 start2 end2 bad irr)))
;; since missed opts are more important to report, they win
(missed-opt-report-entry new-stxs+msgs start1 end1 bad irr)]
[`(,(report-entry ss+ms1 start1 end1) ,(report-entry ss+ms2 start2 end2))
;; both are opts
(report-entry new-stxs+msgs start1 end1)]))
(define-unit tool@
(import drracket:tool^)
(export drracket:tool-exports^)