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

Use various shades of pink/red for highlights depending on the badness.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-06-29 10:45:07 -04:00
parent 47af9d51bc
commit d33c13e0f6
1 changed files with 71 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -21,6 +21,28 @@
(define (performance-report-callback drr-frame) (define (performance-report-callback drr-frame)
(send (send drr-frame get-definitions-text) add-highlights)) (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)))))))
(define remove-highlights-mixin (define remove-highlights-mixin
(mixin ((class->interface text%)) () (mixin ((class->interface text%)) ()
(inherit begin-edit-sequence (inherit begin-edit-sequence
@ -28,13 +50,53 @@
insert insert
get-text) get-text)
(define highlights '()) (define highlights '())
(define color-table #f)
(define (highlight-irritant i)
(define pos (syntax-position i))
(and pos
(let ([start (sub1 pos)]
[end (sub1 (+ pos (syntax-span i)))]
[color "red"]
[caret-space #f]
[style 'hollow-ellipse])
;; high priority, to display above the coloring
(send this highlight-range
start end color caret-space 'high style)
;; info needed to remove the highlight
(list start end color caret-space style))))
(define (highlight-entry l)
(match l
[(log-entry kind msg stx (? number? pos))
(let* ([start (sub1 pos)]
[end (+ start (syntax-span stx))]
[opt? (opt-log-entry? l)] ;; opt or missed opt?
[color (if opt?
"lightgreen"
(vector-ref color-table
(missed-opt-log-entry-badness l)))])
(send this highlight-range start end color)
(send this set-clickback start end
(lambda (ed start end)
(message-box "Performance Report" msg)))
;; 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-log-entry-irritants l))))))]
[_ '()])) ; no source location, don't highlight anything
(define/public (add-highlights) (define/public (add-highlights)
(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
@ -43,42 +105,14 @@
(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 (reverse log)) (define max-badness
(define (highlight-irritant i) (for/fold ([max-badness 0])
(define pos (syntax-position i)) ([l (in-list log)]
(and pos #:when (missed-opt-log-entry? l))
(let ([start (sub1 pos)] (max max-badness (missed-opt-log-entry-badness l))))
[end (sub1 (+ pos (syntax-span i)))] (unless (= max-badness 0) ; no missed opts, color table code would error
[color "red"] (set! color-table (make-color-table max-badness)))
[caret-space #f] (define new-highlights (map highlight-entry log))
[style 'hollow-ellipse])
;; high priority, to display above the coloring
(send this highlight-range
start end color caret-space 'high style)
;; info needed to remove the highlight
(list start end color caret-space style))))
;; highlight
(define new-highlights
(for/list ([l (in-list log)])
(match l
[(log-entry kind msg stx (? number? pos))
(let* ([start (sub1 pos)]
[end (+ start (syntax-span stx))]
[opt? (opt-log-entry? l)] ;; opt or missed opt?
[color (if opt? "lightgreen" "pink")])
(send this highlight-range start end color)
(send this set-clickback start end
(lambda (ed start end)
(message-box "Performance Report" msg)))
;; 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-log-entry-irritants l))))))]
[_ '()]))) ; no source location, don't highlight anything
(set! highlights (append (apply append new-highlights) highlights))) (set! highlights (append (apply append new-highlights) highlights)))
(define (clear-highlights) (define (clear-highlights)