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

Display each opt/missed-opt separately in the tool.

Browse Source 
This should make it easier to highlight irritants in the popup.

This required redesigning the report data structures.
This commit is contained in:
Vincent St-Amour 2011-07-12 17:55:41 -04:00
parent f4c3e51d3b
commit 8e2645a946
3 changed files with 60 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
collects/typed-scheme/optimizer/tool/display.rkt
View File

@ -1,30 +1,32 @@
#lang racket/base
(require racket/string racket/class racket/gui/base
(require racket/string racket/class racket/gui/base racket/match racket/port
"report.rkt"
unstable/sequence unstable/pretty)
(provide popup-callback make-color-table)
(define (format-message stxs+msgs)
(string-join (for/list ([(stx msg) (in-pairs stxs+msgs)])
(format "~a:~a: ~a\n~a"
(syntax-line stx)
(syntax-column stx)
(pretty-format/write (syntax->datum stx))
msg))
"\n\n"))
(define (format-message stx msg)
(let* ([location (format "~a:~a: " (syntax-line stx) (syntax-column stx))]
[message (format "~a~a\n\n~a" location (syntax->datum stx) msg)])
;; return the message and the starting location of the syntax object
(values message (string-length location))))
(define ((popup-callback stxs+msgs) ed start end)
(define ((popup-callback entry) ed start end)
(match-define (report-entry subs start end badness) entry)
(define text (new text%))
(define win (new dialog%
[label "Performance Report"]
[width 500]
[height 300]))
(define editor-canvas
(new editor-canvas% [parent win] [editor text] [style '(no-hscroll)]))
(send text auto-wrap #t)
(send text insert-port (open-input-string (format-message stxs+msgs)))
(send text lock #t)
(define win (new dialog% [label "Performance Report"]
[width 500] [height 300]))
(define pane (new vertical-pane% [parent win] [alignment '(left center)]))
(for ([s (in-list subs)])
(match-define (sub-report-entry stx msg) s)
(define-values (message stx-start) (format-message stx msg))
(define text (new text%))
(send text auto-wrap #t)
(send text insert-port (open-input-string message))
(send text lock #t)
(new editor-canvas% [parent pane] [editor text]
[style '(no-hscroll no-vscroll)]))
(send win show #t))
(define lowest-badness-color (make-object color% "pink"))

58
collects/typed-scheme/optimizer/tool/report.rkt
View File

@ -6,17 +6,22 @@
typed-scheme/optimizer/logging)
(provide (struct-out report-entry)
(struct-out sub-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))
;; - subs is a list of sub-report-entry, corresponding to all the entries
;; between start and end
;; - badness is 0 for a report-entry containing only optimizations
;; otherwise, it's the sum for all the subs
(struct report-entry (subs start end badness))
;; multiple of these can be contained in a report-entry
(struct sub-report-entry (stx msg))
(struct opt-report-entry sub-report-entry ())
(struct missed-opt-report-entry sub-report-entry (badness irritants))
(define (generate-report this)
(collapse-report (log->report (generate-log this))))
@ -43,35 +48,28 @@
(define (log-entry->report-entry l)
(match l
[(log-entry kind msg stx located-stx (? number? pos))
(define stxs+msgs `((,located-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)))]
(report-entry (list (if (opt-log-entry? l)
(opt-report-entry located-stx msg)
(missed-opt-report-entry
located-stx msg
(missed-opt-log-entry-badness l)
(missed-opt-log-entry-irritants l))))
start end
(if (opt-log-entry? l) ; badness
0
(missed-opt-log-entry-badness 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)]))
(match* (prev l)
[((report-entry subs1 start1 end1 badness1)
(report-entry subs2 start2 end2 badness2))
(report-entry (append subs1 subs2)
start1 end1 ; prev includes l
(+ badness1 badness2))]))
;; detect overlapping reports and merge them
(define (collapse-report orig-report)
@ -82,8 +80,8 @@
[prev #f])
([l (in-list report)])
(match* (prev l)
[((report-entry stxs+msgs1 start1 end1)
(report-entry stxs+msgs2 start2 end2))
[((report-entry subs1 start1 end1 badness1)
(report-entry subs2 start2 end2 badness2))
(=> unmatch)
(if (< start2 end1) ; l in within prev
;; merge the two

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

@ -45,30 +45,24 @@
(define (highlight-entry l)
(match l
[(report-entry stxs+msgs start end)
(let* ([opt? (opt-report-entry? l)] ; opt or missed opt?
[color (if opt?
"lightgreen"
(vector-ref color-table
(missed-opt-report-entry-badness l)))])
[(report-entry subs start end badness)
(let ([color (if (= badness 0)
"lightgreen"
(vector-ref color-table badness))])
(send this highlight-range start end color)
(send this set-clickback start end (popup-callback stxs+msgs))
(send this set-clickback start end (popup-callback l))
;; record highlights to undo them later
(cons (list start end color)
;; missed optimizations have irritants, circle them
(if opt?
'()
(filter values ; remove irritants w/o location
(map highlight-irritant
(missed-opt-report-entry-irritants l))))))]))
(filter values ; remove irritants w/o location
(map highlight-irritant
(append-map missed-opt-report-entry-irritants
(filter missed-opt-report-entry?
subs))))))]))
(define/public (add-highlights)
(define report (generate-report this))
(define max-badness
(for/fold ([max-badness 0])
([l (in-list report)]
#:when (missed-opt-report-entry? l))
(max max-badness (missed-opt-report-entry-badness l))))
(define max-badness (apply max (map report-entry-badness report)))
(unless (= max-badness 0) ; no missed opts, color table code would error
(set! color-table (make-color-table max-badness)))
(define new-highlights (map highlight-entry report))