From 8e2645a946bc9a3688402772c149562203f214d5 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 12 Jul 2011 17:55:41 -0400 Subject: [PATCH] Display each opt/missed-opt separately in the tool. This should make it easier to highlight irritants in the popup. This required redesigning the report data structures. --- .../typed-scheme/optimizer/tool/display.rkt | 40 +++++++------ .../typed-scheme/optimizer/tool/report.rkt | 58 +++++++++---------- collects/typed-scheme/optimizer/tool/tool.rkt | 28 ++++----- 3 files changed, 60 insertions(+), 66 deletions(-) diff --git a/collects/typed-scheme/optimizer/tool/display.rkt b/collects/typed-scheme/optimizer/tool/display.rkt index 917b35a095..cb2193e87d 100644 --- a/collects/typed-scheme/optimizer/tool/display.rkt +++ b/collects/typed-scheme/optimizer/tool/display.rkt @@ -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")) diff --git a/collects/typed-scheme/optimizer/tool/report.rkt b/collects/typed-scheme/optimizer/tool/report.rkt index 473af479b2..c4b5340958 100644 --- a/collects/typed-scheme/optimizer/tool/report.rkt +++ b/collects/typed-scheme/optimizer/tool/report.rkt @@ -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 diff --git a/collects/typed-scheme/optimizer/tool/tool.rkt b/collects/typed-scheme/optimizer/tool/tool.rkt index 38c1c66ee0..b7c0f49b94 100644 --- a/collects/typed-scheme/optimizer/tool/tool.rkt +++ b/collects/typed-scheme/optimizer/tool/tool.rkt @@ -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))