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

Display relevant code in pop-up when there's more than one message.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-07-01 11:50:51 -04:00
parent 604e690982
commit 0ce280da89
1 changed files with 76 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,8 +1,9 @@
#lang racket/base #lang racket/base
(require racket/class racket/port racket/list racket/match (require racket/class racket/port racket/list racket/match racket/string
racket/gui/base mrlib/switchable-button racket/gui/base mrlib/switchable-button
racket/unit drracket/tool) racket/unit drracket/tool
unstable/sequence)
(require (prefix-in tr: typed-scheme/typed-reader) (require (prefix-in tr: typed-scheme/typed-reader)
typed-scheme/optimizer/logging) typed-scheme/optimizer/logging)
@ -43,6 +44,13 @@
(min 255 (- max-g (* (sub1 x) bucket-size-g))) (min 255 (- max-g (* (sub1 x) bucket-size-g)))
(min 255 (- max-b (* (sub1 x) bucket-size-b))))))) (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 (define highlights-mixin
(mixin ((class->interface text%)) () (mixin ((class->interface text%)) ()
(inherit begin-edit-sequence (inherit begin-edit-sequence
@ -67,20 +75,24 @@
;; info needed to remove the highlight ;; info needed to remove the highlight
(list start end color caret-space style)))) (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) (define (highlight-entry l)
(match l (match l
[(log-entry kind msg stx (? number? pos)) [(report-entry stxs+msgs start end)
(let* ([start (sub1 pos)] (let* ([opt? (opt-report-entry? l)] ; opt or missed opt?
[end (+ start (syntax-span stx))]
[opt? (opt-log-entry? l)] ;; opt or missed opt?
[color (if opt? [color (if opt?
"lightgreen" "lightgreen"
(vector-ref color-table (vector-ref color-table
(missed-opt-log-entry-badness l)))]) (missed-opt-report-entry-badness l)))])
(send this highlight-range start end color) (send this highlight-range start end color)
(send this set-clickback start end (send this set-clickback start end
(lambda (ed start end) (lambda (ed start end)
(message-box "Performance Report" msg))) (message-box "Performance Report"
(format-message stxs+msgs))))
;; record highlights to undo them later ;; record highlights to undo them later
(cons (list start end color) (cons (list start end color)
;; missed optimizations have irritants, circle them ;; missed optimizations have irritants, circle them
@ -88,15 +100,13 @@
'() '()
(filter values ; remove irritants w/o location (filter values ; remove irritants w/o location
(map highlight-irritant (map highlight-irritant
(missed-opt-log-entry-irritants l))))))] (missed-opt-report-entry-irritants l))))))]))
[_ '()])) ; no source location, don't highlight anything
(define/public (add-highlights) (define (generate-log)
(define portname (send this get-port-name)) (define portname (send this get-port-name))
(define input (open-input-text-editor this)) (define input (open-input-text-editor this))
(port-count-lines! input) (port-count-lines! input)
(define log '()) (define log '())
;; generate the log
(with-intercepted-tr-logging (with-intercepted-tr-logging
(lambda (l) (lambda (l)
(set! log (cons (cdr (vector-ref l 2)) ; log-entry struct (set! log (cons (cdr (vector-ref l 2)) ; log-entry struct
@ -105,34 +115,57 @@
(parameterize ([current-namespace (make-base-namespace)] (parameterize ([current-namespace (make-base-namespace)]
[read-accept-reader #t]) [read-accept-reader #t])
(expand (tr:read-syntax portname input))))) (expand (tr:read-syntax portname input)))))
(set! log (sort log < #:key log-entry-pos)) log)
;; detect overlapping reports
(define-values (rev-log/overlaps _) ;; converts log-entry structs to report-entry structs for further
(for/fold ([rev-log/overlaps '()] ;; 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]) [prev #f])
([l (in-list log)]) ([l (in-list report)])
(match* (prev l) (match* (prev l)
[((log-entry k1 msg1 stx1 pos1) (log-entry k2 msg2 stx2 pos2)) [((report-entry stxs+msgs1 start1 end1)
(report-entry stxs+msgs2 start2 end2))
(=> unmatch) (=> unmatch)
(define end-prev (+ pos1 (syntax-span stx1))) (if (< start2 end1) ; l in within prev
(if (< pos2 end-prev) ; l in within prev
;; merge the two ;; merge the two
(values (cons (merge-entries prev l) (values (cons (merge-entries prev l) (cdr new-report))
(cdr rev-log/overlaps))
;; we don't advance, since we merged ;; we don't advance, since we merged
prev) prev)
(unmatch))] (unmatch))]
[(l1 l2) ; no overlap, just add to the list [(prev l) ; no overlap, just add to the list
(values (cons l rev-log/overlaps) l)]))) (values (cons l new-report) l)])))
(set! log rev-log/overlaps) new-report)
(define/public (add-highlights)
(define report (collapse-report (log->report (generate-log))))
(define max-badness (define max-badness
(for/fold ([max-badness 0]) (for/fold ([max-badness 0])
([l (in-list log)] ([l (in-list report)]
#:when (missed-opt-log-entry? l)) #:when (missed-opt-report-entry? l))
(max max-badness (missed-opt-log-entry-badness l)))) (max max-badness (missed-opt-report-entry-badness l))))
(unless (= max-badness 0) ; no missed opts, color table code would error (unless (= max-badness 0) ; no missed opts, color table code would error
(set! color-table (make-color-table max-badness))) (set! color-table (make-color-table max-badness)))
(define new-highlights (map highlight-entry log)) (define new-highlights (map highlight-entry report))
(set! highlights (append (apply append new-highlights) highlights))) (set! highlights (append (apply append new-highlights) highlights)))
(define (clear-highlights) (define (clear-highlights)
@ -151,27 +184,23 @@
(super-new))) (super-new)))
(define (merge-entries prev l) (define (merge-entries prev l)
(define new-stx (log-entry-stx prev)) ; prev starts earlier than l (define new-stxs+msgs
(define new-pos (log-entry-pos prev)) (append (report-entry-stxs+msgs prev) (report-entry-stxs+msgs l)))
(define new-msg (string-append (log-entry-msg prev) "\n" (log-entry-msg l)))
(match (list prev l) (match (list prev l)
[`(,(missed-opt-log-entry k1 m1 s1 p1 irritants1 m-irr1 badness1) [`(,(missed-opt-report-entry ss+ms1 start1 end1 bad1 irr1)
,(missed-opt-log-entry k2 m2 s2 p2 irritants2 m-irr2 badness2)) ,(missed-opt-report-entry ss+ms2 start2 end2 bad2 irr2))
;; both are missed opts ;; we take start1 and end1 since prev includes l
(missed-opt-log-entry #f ; kind doesn't matter at this point (missed-opt-report-entry new-stxs+msgs start1 end1
new-msg new-stx new-pos (+ bad1 bad2) (append irr1 irr2))]
(append irritants1 irritants2) [(or `(,(missed-opt-report-entry ss+ms1 start1 end1 bad irr)
#f ; merged-irritants either ,(report-entry ss+ms2 start2 end2))
(+ badness1 badness2))] `(,(report-entry ss+ms1 start1 end1)
[(or `(,(missed-opt-log-entry k1 m1 s1 p1 irritants m-irr badness) ,(missed-opt-report-entry ss+ms2 start2 end2 bad irr)))
,(log-entry k2 m2 s2 p2))
`(,(log-entry k1 m1 s1 p1)
,(missed-opt-log-entry k2 m2 s2 p2 irritants m-irr badness)))
;; since missed opts are more important to report, they win ;; since missed opts are more important to report, they win
(missed-opt-log-entry #f new-msg new-stx new-pos irritants #f badness)] (missed-opt-report-entry new-stxs+msgs start1 end1 bad irr)]
[`(,(log-entry k1 m1 s1 p1) ,(log-entry k2 m2 s2 p2)) [`(,(report-entry ss+ms1 start1 end1) ,(report-entry ss+ms2 start2 end2))
;; both are opts ;; both are opts
(log-entry #f new-msg new-stx new-pos)])) (report-entry new-stxs+msgs start1 end1)]))
(define-unit tool@ (define-unit tool@
(import drracket:tool^) (import drracket:tool^)