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

Make performance-report state local, to support multiple files at once.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-06-28 18:07:18 -04:00
parent 092df83c18
commit 47af9d51bc
1 changed files with 59 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -17,58 +17,9 @@
bitmap%
(collection-file-path "performance-report.png" "icons") 'png/mask))
(define highlights '())
;; performance-report-callback : drracket:unit:frame<%> -> void
(define (performance-report-callback drr-frame)
(define defs (send drr-frame get-definitions-text)) ; : text%
(define portname (send defs get-port-name))
(define input (open-input-text-editor defs))
(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)))))
(set! log (reverse log))
(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 defs 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 defs highlight-range start end color)
(send defs set-clickback start end
(lambda (ed start end)
(message-box "Performance Report" msg)))
(cons (list start end color) ; record highlights to undo them later
;; 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)))
(send (send drr-frame get-definitions-text) add-highlights))
(define remove-highlights-mixin
(mixin ((class->interface text%)) ()
@ -76,16 +27,73 @@
end-edit-sequence
insert
get-text)
(define highlights '())
(define/public (add-highlights)
(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)))))
(set! log (reverse log))
(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))))
;; 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)))
(define (clear-highlights)
(for ([h (in-list highlights)])
(match h
[`(,start ,end . ,rest )
(send this unhighlight-range . h)
(send this remove-clickback start end)])))
(send this remove-clickback start end)]))
(set! highlights '()))
(define/augment (after-insert start len)
(clear-highlights))
(define/augment (after-delete start len)
(clear-highlights))
(super-new)))
(define-unit tool@