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

Circle irritants.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-06-27 14:16:28 -04:00
parent a134e4ffb7
commit 5ddfcfba9d
2 changed files with 21 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/typed-scheme/optimizer/logging.rkt
View File

@ -16,7 +16,7 @@
(format "~a:~a" line col)
"(no location)")))
(struct log-entry (msg raw-msg stx pos) #:prefab)
(struct log-entry (msg raw-msg stx pos irritants) #:prefab)
;; to identify log messages that come from the optimizer
;; to be stored in the data section of log messages
@ -43,9 +43,11 @@
(define (log-optimization msg stx
#:from [from "TR opt"]
#:show-badness? [show-badness? #f])
#:show-badness? [show-badness? #f]
#:irritants [irritants #f])
(let* ([new-message (gen-log-message msg stx from show-badness?)]
[new-entry (log-entry new-message msg stx (syntax-position stx))])
[new-entry (log-entry new-message msg stx (syntax-position stx)
irritants)])
(set! log-so-far (cons new-entry log-so-far))))
;; once the optimizer is done, we sort the log according to source
@ -60,14 +62,15 @@
#:from "TR missed opt"
#:show-badness?
(let ([badness (missed-optimization-badness x)])
(and (> badness 1) badness))))
(and (> badness 1) badness))
#:irritants (missed-optimization-irritants x)))
missed-optimizations-log)
(for-each (lambda (x) (log-message logger 'warning (log-entry-msg x)
(cons optimization-log-key x)))
(sort (remove-duplicates log-so-far)
(match-lambda*
[(list (log-entry msg-x raw-x stx-x pos-x)
(log-entry msg-y raw-y stx-y pos-y))
[(list (log-entry msg-x raw-x stx-x pos-x irr-x)
(log-entry msg-y raw-y stx-y pos-y irr-y))
(cond [(not (or pos-x pos-y))
;; neither have location, sort by message
(string<? msg-x msg-y)]

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

@ -43,11 +43,17 @@
[read-accept-reader #t])
(expand (tr:read-syntax portname input)))))
(set! log (reverse log))
(define (highlight-irritant i)
(let ([res (list (sub1 (syntax-position i))
(sub1 (+ (syntax-position i) (syntax-span i)))
"red" #f 'high 'hollow-ellipse)])
(send defs highlight-range . res)
res))
;; highlight
(define new-highlights
(for/list ([l (in-list log)])
(match l
[(log-entry msg raw-msg stx (app sub1 pos))
[(log-entry msg raw-msg stx (app sub1 pos) irritants)
(let* ([end (+ pos (syntax-span stx))]
[opt? (regexp-match #rx"^TR opt:" msg)] ;; opt or missed opt?
[color (if opt? "lightgreen" "pink")])
@ -55,8 +61,11 @@
(send defs set-clickback pos end
(lambda (ed start end)
(message-box "Performance Report" raw-msg)))
(list pos end color))]))) ; record the highlight, to undo it later
(set! highlights (append new-highlights highlights)))
(list (list pos end color) ; record highlights to undo them later
(if irritants
(map highlight-irritant irritants)
'())))])))
(set! highlights (append (apply append new-highlights) highlights)))
(define remove-highlights-mixin
(mixin ((class->interface text%)) ()