Move Optimization Coach to PLaneT 2.
This commit is contained in:
Vincent St-Amour
parent
54c8394280
commit
2c8e5f9acb
|
|
@ -260,19 +260,6 @@ appears at any time.
|
||||||
|
|
||||||
See also @secref["module-browser"].}
|
See also @secref["module-browser"].}
|
||||||
|
|
||||||
@item{@defmenuitem{Show Optimization Coach}
|
|
||||||
Shows information about opportunities for
|
|
||||||
optimizations.
|
|
||||||
|
|
||||||
See also @secref[#:doc '(lib "ts-guide.scrbl" "typed-racket" "scribblings")
|
|
||||||
"optimization-coach"].}
|
|
||||||
|
|
||||||
@item{@defmenuitem{Hide Optimization Coach} Hides the optimization coach.
|
|
||||||
|
|
||||||
See also @secref[#:doc '(lib "ts-guide.scrbl" "typed-racket" "scribblings")
|
|
||||||
"optimization-coach"].}
|
|
||||||
|
|
||||||
|
|
||||||
]
|
]
|
||||||
|
|
||||||
Note: whenever a program is run, the interactions window is made
|
Note: whenever a program is run, the interactions window is made
|
||||||
|
|
|
||||||
|
|
@ -1194,20 +1194,3 @@ This file defines two sorts of primitives. All of them are provided into any mod
|
||||||
|
|
||||||
(define-syntax-rule (for*/flvector: e ...)
|
(define-syntax-rule (for*/flvector: e ...)
|
||||||
(base-for/flvector: for*: e ...))
|
(base-for/flvector: for*: e ...))
|
||||||
|
|
||||||
|
|
||||||
(provide optimization-coach-profile)
|
|
||||||
(require profile/sampler profile/analyzer profile/render-text)
|
|
||||||
(require racket/serialize)
|
|
||||||
(define-syntax (optimization-coach-profile stx)
|
|
||||||
(syntax-parse stx
|
|
||||||
[(_ body ...)
|
|
||||||
(ignore
|
|
||||||
#`(let ([sampler (create-sampler (current-thread) 0.005)])
|
|
||||||
body ...
|
|
||||||
(sampler 'stop)
|
|
||||||
(define samples (sampler 'get-snapshots))
|
|
||||||
(render (analyze-samples samples))
|
|
||||||
(with-output-to-file #,(string-append (path->string (syntax-source stx)) ".profile")
|
|
||||||
#:exists 'replace
|
|
||||||
(lambda () (write (serialize samples))))))]))
|
|
||||||
|
|
|
||||||
|
|
@ -2,5 +2,3 @@
|
||||||
|
|
||||||
(define scribblings '(("scribblings/ts-reference.scrbl" (multi-page) (language 4))
|
(define scribblings '(("scribblings/ts-reference.scrbl" (multi-page) (language 4))
|
||||||
("scribblings/ts-guide.scrbl" (multi-page) (language 5))))
|
("scribblings/ts-guide.scrbl" (multi-page) (language 5))))
|
||||||
(define drracket-tools '(("optimizer/tool/tool.rkt")))
|
|
||||||
(define drracket-tool-names '("Optimization Coach"))
|
|
||||||
|
|
|
||||||
|
|
@ -1,88 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
;; causality merging, for TR optimizations
|
|
||||||
|
|
||||||
(require racket/list
|
|
||||||
"structs.rkt")
|
|
||||||
|
|
||||||
(provide causality-merging)
|
|
||||||
|
|
||||||
(define (causality-merging log)
|
|
||||||
(for/fold ([res '()])
|
|
||||||
([new (in-list log)])
|
|
||||||
(cond [(missed-opt-log-entry? new)
|
|
||||||
(maybe-merge-with-parent new res)]
|
|
||||||
[else
|
|
||||||
(cons new res)]))) ; no merging for opts
|
|
||||||
|
|
||||||
;; is parent the "parent" missed optimization of child?
|
|
||||||
;; this determines whether they get reported together or not
|
|
||||||
;; currently, parents and children must be of the same kind of missed
|
|
||||||
;; optimization, and the child must be an irritant of the parent, or be a
|
|
||||||
;; merged irritant of the parent
|
|
||||||
(define (parent-of? parent child)
|
|
||||||
(and (missed-opt-log-entry? parent) ; only applicable for missed opts
|
|
||||||
(missed-opt-log-entry? child)
|
|
||||||
(equal? (log-entry-kind parent)
|
|
||||||
(log-entry-kind child))
|
|
||||||
(member (log-entry-stx child)
|
|
||||||
(append (missed-opt-log-entry-irritants parent)
|
|
||||||
(missed-opt-log-entry-merged-irritants parent)))))
|
|
||||||
|
|
||||||
;; combine reporting of two missed optimizations, increasing badness in the
|
|
||||||
;; process
|
|
||||||
(define (combine-missed-optimizations parent child)
|
|
||||||
(missed-opt-log-entry
|
|
||||||
(log-entry-kind parent) ; same as child's
|
|
||||||
(log-entry-msg parent)
|
|
||||||
(log-entry-stx parent) ; we report the outermost one
|
|
||||||
(log-entry-located-stx parent)
|
|
||||||
(log-entry-pos parent)
|
|
||||||
|
|
||||||
(remove-duplicates
|
|
||||||
(append (remove (log-entry-stx child)
|
|
||||||
(missed-opt-log-entry-irritants parent))
|
|
||||||
(missed-opt-log-entry-irritants child)))
|
|
||||||
(remove-duplicates
|
|
||||||
(append (missed-opt-log-entry-merged-irritants child)
|
|
||||||
(missed-opt-log-entry-merged-irritants parent)
|
|
||||||
;; we merge child in, keep it for future merges
|
|
||||||
(list (log-entry-stx child))))
|
|
||||||
(+ (missed-opt-log-entry-badness parent)
|
|
||||||
(missed-opt-log-entry-badness child))))
|
|
||||||
|
|
||||||
;; log-entry (listof log-entry) -> log-entry
|
|
||||||
;; add a new missed opt to the list, maybe replacing its parent / children
|
|
||||||
(define (maybe-merge-with-parent new log-so-far)
|
|
||||||
;; check if the new one is the child of an old one
|
|
||||||
;; for/first is ok, since we can only have one parent in the list
|
|
||||||
;; (if we had more, one would have to be the parent of the other, so
|
|
||||||
;; only one would be in the list)
|
|
||||||
(define parent (for/first ([m (in-list log-so-far)]
|
|
||||||
#:when (parent-of? m new))
|
|
||||||
m))
|
|
||||||
;; do we have children in the list, if so, merge with all of them
|
|
||||||
(define children (for/list ([m (in-list log-so-far)]
|
|
||||||
#:when (parent-of? new m))
|
|
||||||
m))
|
|
||||||
(cond [parent
|
|
||||||
;; we found our parent, merge with it
|
|
||||||
(if (member (log-entry-stx new)
|
|
||||||
(missed-opt-log-entry-merged-irritants
|
|
||||||
parent))
|
|
||||||
;; we have been merged in the past, do nothing
|
|
||||||
log-so-far
|
|
||||||
;; do the actual merge
|
|
||||||
(cons (combine-missed-optimizations parent new)
|
|
||||||
(remove parent log-so-far)))]
|
|
||||||
[(not (null? children))
|
|
||||||
;; we found children, merge with them
|
|
||||||
(let ([new (for/fold ([new new])
|
|
||||||
([child children])
|
|
||||||
(combine-missed-optimizations new child))])
|
|
||||||
(cons new
|
|
||||||
(filter (lambda (x) (not (member x children)))
|
|
||||||
log-so-far)))]
|
|
||||||
[else
|
|
||||||
;; no related entry, just add the new one
|
|
||||||
(cons new log-so-far)]))
|
|
||||||
|
|
@ -1,113 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require racket/string racket/class racket/gui/base racket/match racket/port
|
|
||||||
framework syntax/to-string
|
|
||||||
"structs.rkt"
|
|
||||||
unstable/sequence unstable/pretty
|
|
||||||
images/icons/symbol)
|
|
||||||
|
|
||||||
(provide popup-callback make-color-table)
|
|
||||||
|
|
||||||
(define popup-width 500)
|
|
||||||
(define popup-height 300)
|
|
||||||
|
|
||||||
(define tt-style-delta (new style-delta%))
|
|
||||||
(send tt-style-delta set-family 'modern)
|
|
||||||
|
|
||||||
(define ((popup-callback entry) ed start end)
|
|
||||||
(match-define (report-entry subs start end badness) entry)
|
|
||||||
(define win (new frame% [label "Optimization Coach"]
|
|
||||||
[width popup-width] [height popup-height]))
|
|
||||||
(define pane (new text% [auto-wrap #t]))
|
|
||||||
(define canvas
|
|
||||||
(new editor-canvas% [parent win] [editor pane] [style '(no-hscroll)]))
|
|
||||||
(for-each (format-sub-report-entry pane) subs)
|
|
||||||
(send canvas scroll-to 0 0 0 0 #t) ; display the beginning
|
|
||||||
(send pane lock #t)
|
|
||||||
(send win show #t))
|
|
||||||
|
|
||||||
;; each sub-entry is displayed in its own text%, contained in the main
|
|
||||||
;; editor, to simplify irritant highlighting
|
|
||||||
(define ((format-sub-report-entry pane) s)
|
|
||||||
(match-define (sub-report-entry stx msg provenance) s)
|
|
||||||
|
|
||||||
(define usable-width (- popup-width 20)) ; minus the scrollbar
|
|
||||||
|
|
||||||
;; the location, the syntax and the message are in separate editors
|
|
||||||
(define location-text (new text:basic% [auto-wrap #t]))
|
|
||||||
(define location (format "~a:~a:" (syntax-line stx) (syntax-column stx)))
|
|
||||||
(send location-text insert-port (open-input-string location))
|
|
||||||
(send location-text lock #t)
|
|
||||||
;; add to the main editor
|
|
||||||
(send pane insert
|
|
||||||
(new editor-snip% [editor location-text] [with-border? #f]))
|
|
||||||
(send pane insert-port (open-input-string "\n"))
|
|
||||||
|
|
||||||
(define syntax-text (new text:basic%))
|
|
||||||
;; typeset the syntax as code
|
|
||||||
(send syntax-text change-style tt-style-delta)
|
|
||||||
(send syntax-text insert-port
|
|
||||||
(open-input-string (syntax->string #`(#,stx)))) ; takes a list of stxs
|
|
||||||
;; circle irritants, if necessary
|
|
||||||
(when (missed-opt-report-entry? s)
|
|
||||||
(for ([i (in-list (missed-opt-report-entry-irritants s))]
|
|
||||||
#:when (syntax-position i))
|
|
||||||
(define start (- (syntax-position i) (syntax-position stx)))
|
|
||||||
(define len (syntax-span i))
|
|
||||||
;; will be off if there are comments inside an irritant (span will be
|
|
||||||
;; higher than what's actually displayed), but unless we make the
|
|
||||||
;; located version of irritants available, this is the best we can do
|
|
||||||
(send syntax-text highlight-range
|
|
||||||
start (+ start len) "pink" #f 'high 'rectangle)))
|
|
||||||
(send syntax-text set-max-width usable-width)
|
|
||||||
(send syntax-text auto-wrap #t)
|
|
||||||
(send syntax-text lock #t)
|
|
||||||
(send pane insert
|
|
||||||
(new editor-snip% [editor syntax-text] [max-width popup-width]
|
|
||||||
[with-border? #f] [bottom-margin 10]))
|
|
||||||
(send pane insert-port (open-input-string "\n"))
|
|
||||||
|
|
||||||
(define message-text (new text:basic% [auto-wrap #t]))
|
|
||||||
(send message-text insert
|
|
||||||
(make-object image-snip% (if (missed-opt-report-entry? s)
|
|
||||||
(x-icon #:height 20)
|
|
||||||
(check-icon #:height 20))))
|
|
||||||
(send message-text insert-port
|
|
||||||
(open-input-string (string-append " " msg)))
|
|
||||||
;; adjust display
|
|
||||||
(send message-text set-max-width usable-width)
|
|
||||||
(send message-text auto-wrap #t)
|
|
||||||
(send message-text lock #t)
|
|
||||||
(send pane insert
|
|
||||||
(new editor-snip% [editor message-text] [max-width popup-width]
|
|
||||||
[with-border? #f] [top-margin 10] [bottom-margin 15]))
|
|
||||||
|
|
||||||
;; to place the next sub-entry below
|
|
||||||
(send pane insert-port (open-input-string "\n\n"))
|
|
||||||
(define line-bitmap (make-object bitmap% usable-width 5))
|
|
||||||
(define bitmap-dc (make-object bitmap-dc% line-bitmap))
|
|
||||||
(send bitmap-dc draw-line 0 2.5 usable-width 2.5)
|
|
||||||
(send pane insert (make-object image-snip% line-bitmap))
|
|
||||||
(send pane insert-port (open-input-string "\n\n")))
|
|
||||||
|
|
||||||
(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)))))))
|
|
||||||
|
|
@ -1,77 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require "structs.rkt" "utils.rkt" "profiling.rkt")
|
|
||||||
|
|
||||||
(provide report-hidden-costs)
|
|
||||||
|
|
||||||
(define (report-hidden-costs info-log profile hot-functions)
|
|
||||||
(apply
|
|
||||||
append
|
|
||||||
(for/list ([node (in-list (profile-nodes profile))])
|
|
||||||
(process-profile-node node hot-functions info-log
|
|
||||||
(profile-total-time profile)))))
|
|
||||||
|
|
||||||
(define (process-profile-node profile-entry hot-functions info-log total-time)
|
|
||||||
(define produced-entries '())
|
|
||||||
(define (emit e) (set! produced-entries (cons e produced-entries)))
|
|
||||||
|
|
||||||
(define inside-hot-function? (memq profile-entry hot-functions))
|
|
||||||
|
|
||||||
(define (inside-us? pos)
|
|
||||||
(pos-inside-us? pos (node-pos profile-entry) (node-span profile-entry)))
|
|
||||||
|
|
||||||
(define badness-multiplier (/ (node-self profile-entry) total-time))
|
|
||||||
;; base values below are arbitrary
|
|
||||||
;; uses ceiling to never go down to 0
|
|
||||||
;; both badness and badness-multiplier are non-0
|
|
||||||
(define parameter-access-badness (ceiling (* 20 badness-multiplier)))
|
|
||||||
(define struct-construction-badness (ceiling (* 20 badness-multiplier)))
|
|
||||||
(define exact-real-arith-badness (ceiling (* 20 badness-multiplier)))
|
|
||||||
|
|
||||||
(define (check-hidden-cost kind message badness)
|
|
||||||
(when inside-hot-function?
|
|
||||||
(for/list ([info-entry (in-list info-log)]
|
|
||||||
#:when (info-log-entry? info-entry)
|
|
||||||
#:when (equal? (log-entry-kind info-entry) kind)
|
|
||||||
#:when (inside-us? (log-entry-pos info-entry)))
|
|
||||||
(define start (sub1 (log-entry-pos info-entry)))
|
|
||||||
(define end (+ start (syntax-span (log-entry-stx info-entry))))
|
|
||||||
(emit (report-entry
|
|
||||||
(list (missed-opt-report-entry
|
|
||||||
(log-entry-located-stx info-entry)
|
|
||||||
message
|
|
||||||
'hidden-cost
|
|
||||||
badness
|
|
||||||
'())) ; no irritants to highlight
|
|
||||||
start end
|
|
||||||
badness)))))
|
|
||||||
|
|
||||||
(check-hidden-cost
|
|
||||||
"hidden parameter"
|
|
||||||
(string-append "This function may implicitly dereference the "
|
|
||||||
"`current-output-port' parameter. " ;; TODO hard coded
|
|
||||||
"It may be faster to take the value of the "
|
|
||||||
"parameter once, outside hot code, and pass it "
|
|
||||||
"to this function as an argument.")
|
|
||||||
parameter-access-badness)
|
|
||||||
|
|
||||||
(check-hidden-cost
|
|
||||||
"struct constructor"
|
|
||||||
(string-append
|
|
||||||
"This struct constructor is used in hot code. "
|
|
||||||
"Allocating structs is expensive, consider using vectors instead. "
|
|
||||||
"To keep the same interface, consider defining macro wrappers "
|
|
||||||
"around the vector operations that have the same name as the "
|
|
||||||
"struct constructor and accessors.")
|
|
||||||
struct-construction-badness)
|
|
||||||
|
|
||||||
(check-hidden-cost
|
|
||||||
"exact real arith"
|
|
||||||
(string-append
|
|
||||||
"This expression may use exact rational arithmetic, which is inefficient. "
|
|
||||||
"You can avoid this by using operations that don't return fractional "
|
|
||||||
;; TODO don't hard-code `quotient', show the right one depending on the operation
|
|
||||||
"results, such as `quotient', or using floating-point numbers.")
|
|
||||||
exact-real-arith-badness)
|
|
||||||
|
|
||||||
produced-entries)
|
|
||||||
|
|
@ -1,287 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
;;;; Processing of mzc inliner logs.
|
|
||||||
|
|
||||||
(require racket/match racket/list racket/string unstable/list
|
|
||||||
"structs.rkt" "utils.rkt" "instrumentation.rkt" "profiling.rkt")
|
|
||||||
|
|
||||||
(provide report-inlining)
|
|
||||||
|
|
||||||
(define (report-inlining log profile hot-functions)
|
|
||||||
(define grouped-events
|
|
||||||
(group-by equal? #:key log-entry-pos log)) ; right file, so that's enough
|
|
||||||
(apply
|
|
||||||
append
|
|
||||||
(for/list ([group (in-list grouped-events)])
|
|
||||||
(process-function group profile hot-functions))))
|
|
||||||
|
|
||||||
|
|
||||||
;;; Log processing. Interprets the log entries, and produces new ones.
|
|
||||||
;;; This is similar in spirit to the post-processing done for missed-opts in
|
|
||||||
;;; the TR logger.
|
|
||||||
|
|
||||||
(define (success? l) (equal? success-key (log-entry-kind l)))
|
|
||||||
(define (failure? l) (equal? failure-key (log-entry-kind l)))
|
|
||||||
(define (out-of-fuel? l) (equal? out-of-fuel-key (log-entry-kind l)))
|
|
||||||
|
|
||||||
;; f gets inlined in f (or tried to)
|
|
||||||
(define (self-inline? l)
|
|
||||||
(match (inliner-log-entry-inlining-event l)
|
|
||||||
[(inlining-event kind name loc where-name where-loc size threshold)
|
|
||||||
(match* (loc where-loc)
|
|
||||||
[((list path line col pos span)
|
|
||||||
(list where-path where-line where-col))
|
|
||||||
(and (equal? path where-path)
|
|
||||||
(= col where-col)
|
|
||||||
(= line where-line))]
|
|
||||||
[(hunoz hukairz) #f])])) ; we assume it is not, to be conservative
|
|
||||||
|
|
||||||
(define (unrolling? l) (and (success? l) (self-inline? l)))
|
|
||||||
|
|
||||||
(define (n-unrollings group) (length (filter unrolling? group)))
|
|
||||||
(define (n-successes group) (- (length (filter success? group))
|
|
||||||
(n-unrollings group)))
|
|
||||||
(define (n-failures group) (length (filter failure? group)))
|
|
||||||
(define (n-out-of-fuels group) (length (filter out-of-fuel? group)))
|
|
||||||
|
|
||||||
;; self out-of-fuels are not interesting, they're the end of loop unrolling
|
|
||||||
(define (self-out-of-fuel? l) (and (out-of-fuel? l) (self-inline? l)))
|
|
||||||
|
|
||||||
(define (any-self-o-o-f? group) (ormap self-out-of-fuel? group))
|
|
||||||
|
|
||||||
(define (counts-as-a-missed-opt? group)
|
|
||||||
(or (> (n-failures group) 0) ; any straight failure is a problem
|
|
||||||
(> (n-out-of-fuels group) (n-successes group)); fails more often than not
|
|
||||||
))
|
|
||||||
|
|
||||||
|
|
||||||
;; Process the inlining logs corresponding to a single function.
|
|
||||||
(define (process-function log profile hot-functions)
|
|
||||||
(define total-time (profile-total-time profile))
|
|
||||||
(define produced-entries '())
|
|
||||||
(let/ec escape
|
|
||||||
;; prune this entry from the logs, but return what we produced so far
|
|
||||||
(define (prune) (escape produced-entries))
|
|
||||||
(match (car log) ; events are grouped, first element is representative
|
|
||||||
[(log-entry kind msg stx located-stx pos)
|
|
||||||
|
|
||||||
;; #f if no profiling info is available for this function
|
|
||||||
;; takes in either a single pos number or a pair of numbers (line col)
|
|
||||||
(define (pos->node pos)
|
|
||||||
(for/first ([p (in-list (profile-nodes profile))]
|
|
||||||
#:when (if (pair? pos)
|
|
||||||
(and (equal? (car pos) (node-line p))
|
|
||||||
(equal? (cdr pos) (node-col p)))
|
|
||||||
(equal? pos (node-pos p))))
|
|
||||||
p))
|
|
||||||
(define profile-entry (pos->node pos))
|
|
||||||
|
|
||||||
(define badness-multiplier
|
|
||||||
(if profile-entry
|
|
||||||
(/ (node-self profile-entry) total-time)
|
|
||||||
1))
|
|
||||||
|
|
||||||
;; We consider that a function is a loop if it gets inlined in itself
|
|
||||||
;; at least once.
|
|
||||||
(define is-a-loop?
|
|
||||||
(or (any-self-o-o-f? log) (> (n-unrollings log) 0)))
|
|
||||||
;; From now on, we ignore self-out-of-fuels.
|
|
||||||
(set! log (filter (lambda (l) (not (self-out-of-fuel? l))) log))
|
|
||||||
|
|
||||||
(define inlining-sites
|
|
||||||
(group-by equal? #:key (lambda (x)
|
|
||||||
(inlining-event-where-loc
|
|
||||||
(inliner-log-entry-inlining-event x)))
|
|
||||||
log))
|
|
||||||
|
|
||||||
;; We treat loops specially, mostly to avoid spurious reports.
|
|
||||||
;; For instance, if `f' is a loop, and gets inlined in `g' multiple
|
|
||||||
;; times, it's likely to be unrolling. Same for out-of-fuels in `g'.
|
|
||||||
;; Therefore, we don't want to report these as inlinings (or failed
|
|
||||||
;; inlinings). If `g' has multiple call sites for `f', we lose
|
|
||||||
;; precision, and may discard actual inlinings.
|
|
||||||
;; However, we care about `f' being unrolled at least once in `g'.
|
|
||||||
;; If we run out of fuel trying to inline `f' in `g' for the first
|
|
||||||
;; time, we report. The reason for this is that it's possible to
|
|
||||||
;; optimize better if `f''s body inside `g' calls `f' than if `g'
|
|
||||||
;; calls `f' directly. For instance, `f' may be a loop involving
|
|
||||||
;; floats, in which case having all calls to `f' originate from `f''s
|
|
||||||
;; body (as opposed to `g') may make unboxing possible.
|
|
||||||
;; Of course, we lose precision if `g' has multiple call sites to `f'.
|
|
||||||
(set! inlining-sites
|
|
||||||
(if (not is-a-loop?)
|
|
||||||
inlining-sites
|
|
||||||
;; `f' is a loop. We ignore anything beyond the first inlining
|
|
||||||
;; in `g'.
|
|
||||||
(for/list ([site (in-list inlining-sites)])
|
|
||||||
;; If at least one inlining of `f' in `g', ignore the rest.
|
|
||||||
(or (for/first ([evt (in-list site)] #:when (success? evt))
|
|
||||||
(list evt))
|
|
||||||
site))))
|
|
||||||
|
|
||||||
;; Some callers are especially interesting if we have profile data.
|
|
||||||
;; If the function under consideration takes a large portion of the
|
|
||||||
;; total time of a given caller, we consider this case interesting.
|
|
||||||
;; This serves as a building block for more interesting patterns, such
|
|
||||||
;; as `key-sites' below.
|
|
||||||
;; returns: caller-profile-node OR #f
|
|
||||||
(define interesting-callers
|
|
||||||
(and profile-entry
|
|
||||||
(filter values
|
|
||||||
(for/list ([edge (node-callers profile-entry)])
|
|
||||||
;; Does this edge take a "large enough" proportion of
|
|
||||||
;; the caller's total time?
|
|
||||||
(define caller-node (edge-caller edge))
|
|
||||||
(and (> (edge-caller-time edge)
|
|
||||||
(* (node-total caller-node) 0.3))
|
|
||||||
caller-node)))))
|
|
||||||
|
|
||||||
;; As above, but consed in front of the inlining info for that caller.
|
|
||||||
(define interesting-callers+sites
|
|
||||||
(and profile-entry
|
|
||||||
;; Can't map over `inlining-sites', since we also consider
|
|
||||||
;; callers that have no inlining reports at all.
|
|
||||||
(for/list ([caller (in-list interesting-callers)])
|
|
||||||
(cons caller
|
|
||||||
;; Find the relevant inlining site information.
|
|
||||||
(or (for/or ([site (in-list inlining-sites)])
|
|
||||||
(match (inlining-event-where-loc
|
|
||||||
(inliner-log-entry-inlining-event
|
|
||||||
(car site)))
|
|
||||||
[`(,caller-path ,caller-line ,caller-col)
|
|
||||||
(and (eq? caller
|
|
||||||
(pos->node (cons caller-line
|
|
||||||
caller-col)))
|
|
||||||
site)]
|
|
||||||
[_ ; can't parse that, give up
|
|
||||||
#f]))
|
|
||||||
'()))))) ; no inlining reports for that caller
|
|
||||||
|
|
||||||
;; If the function under consideration takes a large portion of the
|
|
||||||
;; total time for a given call site, and is not inlined there, we can
|
|
||||||
;; recommend that the user take a closer look at that specific site.
|
|
||||||
;; returns: `(,caller-profile-node . ,call-site-log-entries) OR #f
|
|
||||||
(define key-sites
|
|
||||||
(and profile-entry
|
|
||||||
(for/list ([site (in-list interesting-callers+sites)]
|
|
||||||
;; Not inlined enough at that call site.
|
|
||||||
#:when (counts-as-a-missed-opt? (cdr site)))
|
|
||||||
site)))
|
|
||||||
|
|
||||||
(define pruned-log (apply append inlining-sites))
|
|
||||||
|
|
||||||
(define recommendation
|
|
||||||
(cond [is-a-loop?
|
|
||||||
"Consider making this function smaller to encourage inlining."]
|
|
||||||
[else
|
|
||||||
;; Non-recursive function -> macro
|
|
||||||
"Consider turning this function into a macro to force inlining."]))
|
|
||||||
|
|
||||||
;; Produce as many log entries as necessary.
|
|
||||||
(define (emit e) (set! produced-entries (cons e produced-entries)))
|
|
||||||
(define start (sub1 pos))
|
|
||||||
(define end (+ start (syntax-span stx)))
|
|
||||||
(define (emit-near-miss msg badness)
|
|
||||||
(emit (report-entry
|
|
||||||
(list (missed-opt-report-entry
|
|
||||||
located-stx
|
|
||||||
(format "Missed Inlining ~a\n~a~a"
|
|
||||||
(format-aggregation-string pruned-log)
|
|
||||||
(if msg (format "~a\n" msg) "")
|
|
||||||
recommendation)
|
|
||||||
'inlining
|
|
||||||
badness
|
|
||||||
'())) ; no irritants to highlight
|
|
||||||
start end
|
|
||||||
badness)))
|
|
||||||
(define (emit-success)
|
|
||||||
(emit (report-entry
|
|
||||||
(list (opt-report-entry
|
|
||||||
located-stx
|
|
||||||
(format "Inlining ~a"
|
|
||||||
(format-aggregation-string pruned-log))
|
|
||||||
'inlining))
|
|
||||||
start end
|
|
||||||
0)))
|
|
||||||
|
|
||||||
(define inside-hot-function?
|
|
||||||
(memq profile-entry hot-functions))
|
|
||||||
|
|
||||||
(define (inside-us? h)
|
|
||||||
(pos-inside-us? (node-pos h)
|
|
||||||
(syntax-position located-stx)
|
|
||||||
(syntax-span located-stx)))
|
|
||||||
|
|
||||||
;; To catch hot curried functions.
|
|
||||||
;; Turns out to be useful for the ray tracer, but increases false
|
|
||||||
;; positives for functions with hot loops inside that otherwise are
|
|
||||||
;; uninteresting wrt inlining.
|
|
||||||
(define really-hot-anonymous-function-inside-us?
|
|
||||||
(and hot-functions
|
|
||||||
;; list is sorted in increasing order of time
|
|
||||||
(ormap (lambda (x) (and (inside-us? x)
|
|
||||||
(not (node-id x)))) ; anonymous
|
|
||||||
;; TODO try dropping 3/4
|
|
||||||
(drop hot-functions (quotient (length hot-functions) 2)))))
|
|
||||||
|
|
||||||
;; Prune reports about cold regions.
|
|
||||||
;; We don't want to prune earlier, since traversing cold functions can
|
|
||||||
;; give us advice about hot functions.
|
|
||||||
(when (and (not inside-hot-function?)
|
|
||||||
(not really-hot-anonymous-function-inside-us?)
|
|
||||||
;; Cold successes are useful information.
|
|
||||||
(counts-as-a-missed-opt? pruned-log))
|
|
||||||
(prune))
|
|
||||||
|
|
||||||
(cond [(and (counts-as-a-missed-opt? pruned-log)
|
|
||||||
is-a-loop?
|
|
||||||
;; loops are hard to act upon, only report in extreme cases
|
|
||||||
(< (group-badness pruned-log) 50))
|
|
||||||
(prune)]
|
|
||||||
[(and (counts-as-a-missed-opt? pruned-log)
|
|
||||||
(not is-a-loop?)
|
|
||||||
(not really-hot-anonymous-function-inside-us?)
|
|
||||||
;; needs to have enough failures to report
|
|
||||||
(< (group-badness pruned-log) 6))
|
|
||||||
(prune)]
|
|
||||||
[(and profile-entry (not (null? key-sites)))
|
|
||||||
;; Inlining was not satisfactory for some call sites where we
|
|
||||||
;; accounted for a good portion of the caller's total time.
|
|
||||||
(emit-near-miss
|
|
||||||
(format "Key call site~a: ~a"
|
|
||||||
(if (> (length key-sites) 1) "s" "")
|
|
||||||
(string-join
|
|
||||||
(for/list ([site (in-list key-sites)])
|
|
||||||
(define node (car site))
|
|
||||||
(format "~a ~a:~a"
|
|
||||||
(node-id node)
|
|
||||||
(node-line node)
|
|
||||||
(node-col node)))
|
|
||||||
", "))
|
|
||||||
;; only compute badness for the interesting sites
|
|
||||||
(group-badness (apply append (map cdr key-sites))))]
|
|
||||||
[(counts-as-a-missed-opt? pruned-log)
|
|
||||||
;; Overall inlining ratio is not satisfactory.
|
|
||||||
(emit-near-miss #f (group-badness pruned-log))]
|
|
||||||
[else
|
|
||||||
;; Satisfactory.
|
|
||||||
(emit-success)])
|
|
||||||
|
|
||||||
produced-entries]))) ; return the list of new entries
|
|
||||||
|
|
||||||
(define (group-badness group)
|
|
||||||
(+ (n-failures group) (- (n-out-of-fuels group) (n-successes group))))
|
|
||||||
|
|
||||||
(define (format-aggregation-string group)
|
|
||||||
;; Integer String #:suffix String -> (U Null (List String))
|
|
||||||
;; if n = 0, nothing, if n = 1 singular, o/w plural
|
|
||||||
(define (pluralize n noun #:suffix [suffix "s"])
|
|
||||||
(format "~a ~a~a" n noun (if (> n 1) suffix "")))
|
|
||||||
(define n-u (n-unrollings group))
|
|
||||||
(define n-s (n-successes group))
|
|
||||||
(format "(~a out of ~a~a)"
|
|
||||||
(pluralize n-s "success" #:suffix "es")
|
|
||||||
(+ n-s (n-failures group) (n-out-of-fuels group))
|
|
||||||
(if (> n-u 0)
|
|
||||||
(format " and ~a" (pluralize n-u "unrolling"))
|
|
||||||
"")))
|
|
||||||
|
|
@ -1,239 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require racket/class racket/gui/base racket/string racket/match racket/list
|
|
||||||
unstable/syntax unstable/logging
|
|
||||||
"structs.rkt" "sandbox.rkt")
|
|
||||||
|
|
||||||
(provide generate-logs)
|
|
||||||
|
|
||||||
(define (generate-logs this)
|
|
||||||
(define file-predicate (make-file-predicate this))
|
|
||||||
(define input (open-input-text-editor this))
|
|
||||||
(port-count-lines! input)
|
|
||||||
(define (right-file? l) ; does the log-entry refer to the file we're in?
|
|
||||||
(define stx (log-entry-stx l))
|
|
||||||
(define path
|
|
||||||
(let ([dir (syntax-source-directory stx)]
|
|
||||||
[file (syntax-source-file-name stx)])
|
|
||||||
(if (and dir file)
|
|
||||||
(build-path dir file)
|
|
||||||
#f)))
|
|
||||||
(file-predicate path))
|
|
||||||
(define TR-log '())
|
|
||||||
(define mzc-log '())
|
|
||||||
(define info-log '()) ; for hidden costs
|
|
||||||
(with-intercepted-logging
|
|
||||||
(lambda (l)
|
|
||||||
;; From mzc, create a log-entry from the info.
|
|
||||||
(define entry (mzc-opt-log-message->log-entry (vector-ref l 1)))
|
|
||||||
(when (and entry (right-file? entry))
|
|
||||||
(set! mzc-log (cons entry mzc-log))))
|
|
||||||
(lambda ()
|
|
||||||
(with-intercepted-logging
|
|
||||||
(lambda (l)
|
|
||||||
;; From TR, use the log-entry struct provided.
|
|
||||||
(define entry (vector-ref l 2))
|
|
||||||
(when (right-file? entry)
|
|
||||||
(if (info-log-entry? entry)
|
|
||||||
(set! info-log (cons entry info-log))
|
|
||||||
(set! TR-log (cons entry TR-log)))))
|
|
||||||
(lambda ()
|
|
||||||
(run-inside-optimization-coach-sandbox
|
|
||||||
this
|
|
||||||
(lambda ()
|
|
||||||
(void (compile (read-syntax (send this get-port-name) input))))))
|
|
||||||
'debug 'TR-optimizer))
|
|
||||||
'debug 'optimizer)
|
|
||||||
;; The raw TR logs may contain duplicates from the optimizer traversing
|
|
||||||
;; the same piece of code multiple times.
|
|
||||||
;; Duplicates are not significant (unlike for inlining logs) and we can
|
|
||||||
;; prune them.
|
|
||||||
(values (remove-duplicates TR-log) mzc-log (remove-duplicates info-log)))
|
|
||||||
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
;;;; Inlining pre-processing
|
|
||||||
|
|
||||||
(provide success-key failure-key out-of-fuel-key)
|
|
||||||
|
|
||||||
;;; Low-level log parsing. Goes from strings to log-entry structs.
|
|
||||||
|
|
||||||
(define success-key 'inlining)
|
|
||||||
(define failure-key 'no-inlining)
|
|
||||||
(define out-of-fuel-key 'out-of-fuel)
|
|
||||||
|
|
||||||
;; Inliner logs contain path literals, which are not readable.
|
|
||||||
;; Use a custom reader to parse the logs.
|
|
||||||
|
|
||||||
;; At this point, the #< has already been seen.
|
|
||||||
;; For now, returns a string. Maybe return a path eventually.
|
|
||||||
(define (read-path port)
|
|
||||||
(let ([s (open-output-string)])
|
|
||||||
(unless (string=? (read-string 5 port) "path:")
|
|
||||||
(error "OC path reader: bad path syntax"))
|
|
||||||
(let loop ([c (read-char port)])
|
|
||||||
;; parse until the closing >
|
|
||||||
(cond [(eof-object? c)
|
|
||||||
(error "OC path reader: bad path syntax")]
|
|
||||||
[(not (equal? c #\>))
|
|
||||||
(write-char c s)
|
|
||||||
(loop (read-char port))]
|
|
||||||
[else
|
|
||||||
;; we saw the closing broket, we're done
|
|
||||||
(values (get-output-string s))]))))
|
|
||||||
(define path-readtable
|
|
||||||
(make-readtable
|
|
||||||
(current-readtable)
|
|
||||||
#\<
|
|
||||||
'dispatch-macro
|
|
||||||
(case-lambda
|
|
||||||
[(char port) ; read
|
|
||||||
(read-path port)]
|
|
||||||
[(char port src line col pos) ; read-syntax
|
|
||||||
(error "OC path reader: read-syntax is not supported")])))
|
|
||||||
(define (read/path s)
|
|
||||||
(parameterize ([current-readtable path-readtable]
|
|
||||||
[current-input-port (open-input-string s)])
|
|
||||||
(read)))
|
|
||||||
|
|
||||||
;; String (message from the mzc optimizer) -> log-entry
|
|
||||||
(define (mzc-opt-log-message->log-entry l)
|
|
||||||
(define evt (parse-inlining-event l))
|
|
||||||
(cond [evt
|
|
||||||
(define forged-stx (inlining-event->forged-stx evt))
|
|
||||||
(define kind
|
|
||||||
(match (inlining-event-kind evt)
|
|
||||||
[(== success-key) success-key]
|
|
||||||
[(or (== failure-key) (== 'non-copyable)) failure-key]
|
|
||||||
[(or (== out-of-fuel-key) (== 'too-large)) out-of-fuel-key]
|
|
||||||
[_ (error "Unknown log message type" l)]))
|
|
||||||
(inliner-log-entry kind kind
|
|
||||||
forged-stx forged-stx
|
|
||||||
(syntax-position forged-stx)
|
|
||||||
evt)]
|
|
||||||
[else #f]))
|
|
||||||
|
|
||||||
;; _Where_ this happens (in which function, can't get more precise info).
|
|
||||||
;; Note: sadly, this part still needs to be parsed by a regexp. Inliner logging
|
|
||||||
;; doesn't have control over the format for that part. Since it may include
|
|
||||||
;; unquoted paths, which can include spaces, can't really use the reader
|
|
||||||
;; approach. Backslashes are doubled before we get here, to handle Windows
|
|
||||||
;; paths.
|
|
||||||
(define where-regexp
|
|
||||||
(string-append
|
|
||||||
;; maybe full path info: path, line, col, name
|
|
||||||
;; path allows `:' as the second character (and first, but not a problem)
|
|
||||||
;; to support absolute windows paths (e.g. C:\...)
|
|
||||||
"( in: (([^ :]?[^ ]?[^:]+):([^ :]+):([^ :]+): )?([^ ]+))?"
|
|
||||||
;; maybe module info, useless to us (at least for now)
|
|
||||||
"( in module: [^ ]+)?"))
|
|
||||||
(define (parse-where l)
|
|
||||||
(match (regexp-match where-regexp l)
|
|
||||||
[`(,all
|
|
||||||
,where ,where-loc ,where-path ,where-line ,where-col ,where-name
|
|
||||||
,maybe-module-info)
|
|
||||||
(values (and where-name (string->symbol where-name))
|
|
||||||
(if where-loc
|
|
||||||
(list where-path
|
|
||||||
(string->number where-line)
|
|
||||||
(string->number where-col))
|
|
||||||
#f))])) ; no source location
|
|
||||||
|
|
||||||
(define (parse-inlining-event l)
|
|
||||||
(define (ill-formed)
|
|
||||||
(log-debug (format "OC log parser: ill-formed mzc log entry: ~a" l))
|
|
||||||
#f)
|
|
||||||
;; Inlining log entry strings consist of two parts.
|
|
||||||
;; The first is `read'-able, given the custom reader above that can
|
|
||||||
;; read path literals.
|
|
||||||
;; The second part needs to be parsed with a regexp (see above).
|
|
||||||
;; The two are separated by "#<separator>", which shouldn't clash with
|
|
||||||
;; program identifiers.
|
|
||||||
(cond [(regexp-match #rx"#<separator>" l)
|
|
||||||
(match-define `(,readable-part ,parsable-part)
|
|
||||||
(regexp-split #rx"#<separator>" l))
|
|
||||||
(match (read/path (format "(~a)" readable-part))
|
|
||||||
[`(optimizer: ,kind ,what
|
|
||||||
size: ,size threshold: ,threshold)
|
|
||||||
(define-values (what-name what-loc)
|
|
||||||
(match what
|
|
||||||
[`#(,what-name ,what-path ,what-line ,what-col
|
|
||||||
,what-pos ,what-span ,gen?)
|
|
||||||
(values
|
|
||||||
what-name
|
|
||||||
(list what-path what-line what-col what-pos what-span))]
|
|
||||||
[only-name
|
|
||||||
(values only-name #f)]))
|
|
||||||
(define-values (where-name where-loc)
|
|
||||||
(parse-where parsable-part))
|
|
||||||
(inlining-event kind
|
|
||||||
what-name what-loc
|
|
||||||
where-name where-loc
|
|
||||||
size threshold)]
|
|
||||||
;; can't parse, or log entry not about inlining (e.g. div by 0 detected)
|
|
||||||
[_ (ill-formed)])]
|
|
||||||
[else (ill-formed)]))
|
|
||||||
|
|
||||||
|
|
||||||
(define (inlining-event->forged-stx evt)
|
|
||||||
(match evt
|
|
||||||
[(inlining-event kind name loc where-name where-loc size threshold)
|
|
||||||
(datum->syntax #'here name loc)]))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(require rackunit)
|
|
||||||
|
|
||||||
;; log parsing tests
|
|
||||||
|
|
||||||
;; Windows path
|
|
||||||
(check-equal?
|
|
||||||
(parse-inlining-event "optimizer: out-of-fuel #(.../private/map.rkt:22:14 #<path:C:\\Users\\bernardip\\Documents\\Local\\RacketPortable\\App\\Racket\\collects\\racket\\private\\map.rkt> 22 14 620 335 #t) size: 55 threshold: 8#<separator> in: C:\\Users\\bernardip\\Documents\\Scheme\\fotografia.rkt:23:0: prova2 in module: 'anonymous-module")
|
|
||||||
(inlining-event
|
|
||||||
'out-of-fuel '.../private/map.rkt:22:14
|
|
||||||
(list "C:\\Users\\bernardip\\Documents\\Local\\RacketPortable\\App\\Racket\\collects\\racket\\private\\map.rkt" 22 14 620 335)
|
|
||||||
'prova2
|
|
||||||
(list "C:\\Users\\bernardip\\Documents\\Scheme\\fotografia.rkt" 23 0)
|
|
||||||
55 8))
|
|
||||||
|
|
||||||
(check-equal?
|
|
||||||
(parse-inlining-event "optimizer: out-of-fuel #(sqr #<path:/home/stamourv/src/plt/collects/racket/math.rkt> 35 2 838 93 #f) size: 21 threshold: 6#<separator> in: /home/stamourv/src/examples/example-shapes.rkt:41:0: inC in module: 'example-shapes")
|
|
||||||
(inlining-event
|
|
||||||
'out-of-fuel 'sqr
|
|
||||||
(list "/home/stamourv/src/plt/collects/racket/math.rkt" 35 2 838 93)
|
|
||||||
'inC (list "/home/stamourv/src/examples/example-shapes.rkt" 41 0)
|
|
||||||
21 6))
|
|
||||||
|
|
||||||
(check-equal?
|
|
||||||
(parse-inlining-event "optimizer: inlining #(inC #<path:/home/stamourv/src/examples/example-shapes.rkt> 41 0 993 165 #f) size: 41 threshold: 128#<separator> in: /home/stamourv/src/examples/example-shapes.rkt:27:0: in in module: 'example-shapes")
|
|
||||||
(inlining-event
|
|
||||||
'inlining 'inC
|
|
||||||
(list "/home/stamourv/src/examples/example-shapes.rkt" 41 0 993 165)
|
|
||||||
'in (list "/home/stamourv/src/examples/example-shapes.rkt" 27 0)
|
|
||||||
41 128))
|
|
||||||
|
|
||||||
(check-equal?
|
|
||||||
(parse-inlining-event "optimizer: out-of-fuel #(sqr #<path:/Applications/Racket v5.3/collects/racket/math.rkt> 35 2 838 93 #f) size: 21 threshold: 6#<separator> in: /Users/user/Desktop/Optimization Coach/example-shapes.rkt:41:0: inC in module: 'anonymous-module")
|
|
||||||
(inlining-event
|
|
||||||
'out-of-fuel 'sqr
|
|
||||||
(list "/Applications/Racket v5.3/collects/racket/math.rkt" 35 2 838 93)
|
|
||||||
'inC (list "/Users/user/Desktop/Optimization Coach/example-shapes.rkt" 41 0)
|
|
||||||
21 6))
|
|
||||||
|
|
||||||
(check-equal?
|
|
||||||
(parse-inlining-event
|
|
||||||
"optimizer: inlining #(f unsaved-editor590 2 0 20 14 #f) size: 0 threshold: 64#<separator> in: unsaved-editor590:3:0: g in module: 'anonymous-module")
|
|
||||||
(inlining-event
|
|
||||||
'inlining 'f (list 'unsaved-editor590 2 0 20 14)
|
|
||||||
'g (list "unsaved-editor590" 3 0)
|
|
||||||
0 64))
|
|
||||||
|
|
||||||
(check-equal?
|
|
||||||
(parse-inlining-event
|
|
||||||
"optimizer: inlining #(g unsaved-editor590 3 0 35 16 #f) size: 0 threshold: 64#<separator> in module: 'anonymous-module")
|
|
||||||
(inlining-event
|
|
||||||
'inlining 'g (list 'unsaved-editor590 3 0 35 16)
|
|
||||||
#f #f 0 64))
|
|
||||||
)
|
|
||||||
|
|
@ -1,40 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
;; Only includes pitfall-agnostic locality merging (the one that doesn't
|
|
||||||
;; generate new information).
|
|
||||||
;; Pitfall-specific locality merging is done in the pitfall's file.
|
|
||||||
|
|
||||||
(require racket/match
|
|
||||||
"structs.rkt")
|
|
||||||
|
|
||||||
(provide locality-merging)
|
|
||||||
|
|
||||||
(define (merge-entries prev l)
|
|
||||||
(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 (locality-merging 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])
|
|
||||||
([l (in-list report)])
|
|
||||||
(match* (prev l)
|
|
||||||
[((report-entry subs1 start1 end1 badness1)
|
|
||||||
(report-entry subs2 start2 end2 badness2))
|
|
||||||
(=> unmatch)
|
|
||||||
(if (< start2 end1) ; l in within prev
|
|
||||||
;; merge the two
|
|
||||||
(let ([merged (merge-entries prev l)])
|
|
||||||
(values (cons merged (cdr new-report))
|
|
||||||
merged))
|
|
||||||
(unmatch))]
|
|
||||||
[(prev l) ; no overlap, just add to the list
|
|
||||||
(values (cons l new-report) l)])))
|
|
||||||
new-report)
|
|
||||||
|
|
@ -1,62 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require profile/analyzer profile/sampler racket/class racket/serialize)
|
|
||||||
|
|
||||||
(require "sandbox.rkt")
|
|
||||||
|
|
||||||
(provide generate-profile prune-profile
|
|
||||||
node-source node-line node-col node-pos node-span
|
|
||||||
;; from profile/analyzer
|
|
||||||
(struct-out profile)
|
|
||||||
(struct-out node)
|
|
||||||
(struct-out edge))
|
|
||||||
|
|
||||||
(define ((mk accessor) node)
|
|
||||||
(define src (node-src node))
|
|
||||||
(and src (accessor src)))
|
|
||||||
(define node-source (mk srcloc-source))
|
|
||||||
(define node-line (mk srcloc-line))
|
|
||||||
(define node-col (mk srcloc-column))
|
|
||||||
(define node-pos (mk srcloc-position))
|
|
||||||
(define node-span (mk srcloc-span))
|
|
||||||
|
|
||||||
|
|
||||||
;; For best results, run `optimization-coach-profile' (provided from TR/prims)
|
|
||||||
;; from inside DrRacket (with errortrace on, IIRC)
|
|
||||||
;; Other things I've tried that didn't work as well:
|
|
||||||
;; - `optimization-coach-profile' from command line (TODO was it with errortrace?)
|
|
||||||
;; - profiling executable generated by the instrumentation phase inside an
|
|
||||||
;; OC sandbox (in version control history, plus an attempt with
|
|
||||||
;; `dynamic-require' that was not committed)
|
|
||||||
(define (generate-profile this source profile-file)
|
|
||||||
(define snapshots
|
|
||||||
(with-input-from-file profile-file ;; TODO error gracefully if not found
|
|
||||||
(lambda ()
|
|
||||||
(deserialize (read)))))
|
|
||||||
;; We can't prune what's outside the file yet. We need the entire profile
|
|
||||||
;; to identify hot functions, and to get meaningful caller-callee stats.
|
|
||||||
(analyze-samples snapshots))
|
|
||||||
|
|
||||||
|
|
||||||
;; In some cases, we only want to consider "hot" functions for further
|
|
||||||
;; analysis. `prune-profile' prunes non-hot functions from the profile.
|
|
||||||
;; To determine what is hot, we pick, in order, the hottest functions
|
|
||||||
;; (by self time. total time could be used, but may not work as well)
|
|
||||||
;; until our picks cover `total-relative-time-cutoff' (e.g. half) of
|
|
||||||
;; the total running time.
|
|
||||||
(define total-relative-time-cutoff .95) ; picked arbitrarily, subject to tweaking
|
|
||||||
(define (prune-profile profile)
|
|
||||||
(define total-time (profile-total-time profile))
|
|
||||||
(define target-time (* total-time total-relative-time-cutoff))
|
|
||||||
(define sorted-nodes (sort (profile-nodes profile) > #:key node-self))
|
|
||||||
(define top-nodes
|
|
||||||
(let loop ([nodes sorted-nodes] [res '()] [sum 0])
|
|
||||||
;; The last function we pick can go beyond the target.
|
|
||||||
;; O/w, if we had a single function, taking up 100% time, it would
|
|
||||||
;; be discarded.
|
|
||||||
(cond [(or (null? nodes) (> sum target-time))
|
|
||||||
res]
|
|
||||||
[else
|
|
||||||
(define h (car nodes))
|
|
||||||
(loop (cdr nodes) (cons h res) (+ sum (node-self h)))])))
|
|
||||||
top-nodes)
|
|
||||||
|
|
@ -1,20 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require "instrumentation.rkt" "profiling.rkt"
|
|
||||||
"typed-racket.rkt" "inlining.rkt" "hidden-costs.rkt"
|
|
||||||
"locality-merging.rkt")
|
|
||||||
|
|
||||||
(provide generate-report locality-merging)
|
|
||||||
|
|
||||||
;; profile is currently only used to refine the inlining logs
|
|
||||||
(define (generate-report this profile)
|
|
||||||
(define-values (TR-log mzc-log info-log) (generate-logs this))
|
|
||||||
(define hot-functions (and profile (prune-profile profile)))
|
|
||||||
(append
|
|
||||||
(report-typed-racket TR-log profile hot-functions)
|
|
||||||
(if profile
|
|
||||||
;; inlining and hidden cost reports have too low a SNR to be shown
|
|
||||||
;; w/o profiling-based pruning
|
|
||||||
(append (report-inlining mzc-log profile hot-functions)
|
|
||||||
(report-hidden-costs info-log profile hot-functions))
|
|
||||||
'())))
|
|
||||||
|
|
@ -1,70 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require racket/sandbox racket/port racket/class)
|
|
||||||
|
|
||||||
(provide run-inside-optimization-coach-sandbox
|
|
||||||
make-file-predicate)
|
|
||||||
|
|
||||||
(define (log-output in done-chan)
|
|
||||||
(let loop ()
|
|
||||||
(sync (handle-evt
|
|
||||||
(read-line-evt in 'linefeed)
|
|
||||||
(lambda (line)
|
|
||||||
(cond [(eof-object? line) (channel-put done-chan 'done)]
|
|
||||||
[else
|
|
||||||
(log-warning
|
|
||||||
(format "Optimization Coach Program Output: ~a" line))
|
|
||||||
(loop)]))))))
|
|
||||||
|
|
||||||
(define (run-inside-optimization-coach-sandbox this thunk)
|
|
||||||
(call-with-trusted-sandbox-configuration
|
|
||||||
(lambda ()
|
|
||||||
(define port-name (send this get-port-name))
|
|
||||||
;; If the sandboxed program produces any output, log it as `warning'.
|
|
||||||
;; Mimics what check-syntax does.
|
|
||||||
(define log-output? (log-level? (current-logger) 'warning))
|
|
||||||
(define-values (log-in log-out)
|
|
||||||
(if log-output? (make-pipe) (values #f (open-output-nowhere))))
|
|
||||||
(define log-done-chan (make-channel))
|
|
||||||
(when log-output? (thread (lambda () (log-output log-in log-done-chan))))
|
|
||||||
;; Set up the environment.
|
|
||||||
(begin0
|
|
||||||
(parameterize
|
|
||||||
([current-namespace (make-base-namespace)]
|
|
||||||
[current-load-relative-directory
|
|
||||||
(if (path-string? port-name)
|
|
||||||
(let-values ([(base name _) (split-path port-name)])
|
|
||||||
base)
|
|
||||||
(current-load-relative-directory))]
|
|
||||||
[read-accept-reader #t]
|
|
||||||
[current-output-port log-out]
|
|
||||||
[current-error-port log-out])
|
|
||||||
(thunk))
|
|
||||||
(when log-output?
|
|
||||||
(close-output-port log-out)
|
|
||||||
(sync log-done-chan))))))
|
|
||||||
|
|
||||||
;; Returns a predicate that, given a path, returns whether it corresponds
|
|
||||||
;; to the right file.
|
|
||||||
(define (make-file-predicate this)
|
|
||||||
(define portname (send this get-port-name))
|
|
||||||
(define unsaved-file?
|
|
||||||
(and (symbol? portname)
|
|
||||||
(regexp-match #rx"^unsaved-editor" (symbol->string portname))))
|
|
||||||
(define good-portname-cache #f)
|
|
||||||
(lambda (path) ; (or/c path? #f)
|
|
||||||
(cond [(and good-portname-cache ; cache is populated
|
|
||||||
(equal? path good-portname-cache))
|
|
||||||
#t]
|
|
||||||
[good-portname-cache ; cache is populated, but we have the wrong file
|
|
||||||
#f]
|
|
||||||
[unsaved-file?
|
|
||||||
;; we assume that any log entry without a filename comes from
|
|
||||||
;; the unsaved editor
|
|
||||||
(not path)]
|
|
||||||
;; no cache, ask directly
|
|
||||||
[(send this port-name-matches? path)
|
|
||||||
(set! good-portname-cache path) ; populate cache
|
|
||||||
#t]
|
|
||||||
[else ; different file
|
|
||||||
#f])))
|
|
||||||
|
|
@ -1,44 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require typed-racket/optimizer/logging)
|
|
||||||
|
|
||||||
(provide (struct-out report-entry)
|
|
||||||
(struct-out sub-report-entry)
|
|
||||||
(struct-out opt-report-entry)
|
|
||||||
(struct-out missed-opt-report-entry)
|
|
||||||
(struct-out inliner-log-entry)
|
|
||||||
(struct-out inlining-event)
|
|
||||||
;; from typed-racket/optimizer/logging
|
|
||||||
(struct-out log-entry)
|
|
||||||
(struct-out opt-log-entry)
|
|
||||||
(struct-out missed-opt-log-entry)
|
|
||||||
(struct-out info-log-entry))
|
|
||||||
|
|
||||||
|
|
||||||
;; Similar to the log-entry family of structs, but geared towards GUI display.
|
|
||||||
;; Also designed to contain info for multiple overlapping log entries.
|
|
||||||
;; - 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
|
|
||||||
;; provenance is one of: 'typed-racket 'mzc
|
|
||||||
(struct sub-report-entry (stx msg provenance))
|
|
||||||
(struct opt-report-entry sub-report-entry ())
|
|
||||||
(struct missed-opt-report-entry sub-report-entry (badness irritants))
|
|
||||||
|
|
||||||
|
|
||||||
(struct inliner-log-entry log-entry (inlining-event) #:prefab)
|
|
||||||
|
|
||||||
|
|
||||||
(struct inlining-event (kind ; success, miss, out of fuel, ...
|
|
||||||
name ; _what_ gets inlined
|
|
||||||
loc ; (U #f (List path line col pos span))
|
|
||||||
where-name ; _where_ it gets inlined (enclosing fun)
|
|
||||||
where-loc ; (U #f (List path line col))
|
|
||||||
size ; size of the closure being inlined
|
|
||||||
threshold ; how big of a closure can we inline
|
|
||||||
;; the last two use the same units
|
|
||||||
)
|
|
||||||
#:transparent)
|
|
||||||
|
|
@ -1,398 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require racket/class racket/port racket/list racket/match unstable/sequence
|
|
||||||
racket/gui/base racket/unit drracket/tool mrlib/switchable-button
|
|
||||||
images/compile-time framework
|
|
||||||
(for-syntax racket/base images/icons/misc images/icons/style)
|
|
||||||
string-constants)
|
|
||||||
|
|
||||||
(require "structs.rkt" "report.rkt" "profiling.rkt" "display.rkt")
|
|
||||||
|
|
||||||
(provide tool@ optimization-coach-drracket-button)
|
|
||||||
|
|
||||||
;; DrRacket tool for reporting missed optimizations in the editor.
|
|
||||||
|
|
||||||
(define optimization-coach-bitmap
|
|
||||||
(compiled-bitmap (stopwatch-icon #:height (toolbar-icon-height))))
|
|
||||||
|
|
||||||
(define check-boxes
|
|
||||||
`(("Report Typed Racket optimizations?" .
|
|
||||||
,(match-lambda [(sub-report-entry s m 'typed-racket) #t]
|
|
||||||
[_ #f]))
|
|
||||||
("Report inlining optimizations?" .
|
|
||||||
,(match-lambda [(sub-report-entry s m 'inlining) #t]
|
|
||||||
[_ #f]))
|
|
||||||
("Report hidden costs?" .
|
|
||||||
,(match-lambda [(sub-report-entry s m 'hidden-cost) #t]
|
|
||||||
[_ #f]))))
|
|
||||||
|
|
||||||
(define (copy-definitions definitions)
|
|
||||||
;; this code is from Robby
|
|
||||||
(define definitions-copy
|
|
||||||
(new (class text:basic%
|
|
||||||
;; overriding get-port-name like this ensures
|
|
||||||
;; that the resulting syntax objects are connected
|
|
||||||
;; to the actual definitions-text, not this copy
|
|
||||||
(define/override (get-port-name)
|
|
||||||
(send definitions get-port-name))
|
|
||||||
(super-new))))
|
|
||||||
(send definitions-copy set-style-list
|
|
||||||
(send definitions get-style-list)) ;; speeds up the copy
|
|
||||||
(send definitions copy-self-to definitions-copy)
|
|
||||||
definitions-copy)
|
|
||||||
|
|
||||||
(define-local-member-name
|
|
||||||
get-optimization-coach-menu-item
|
|
||||||
add-highlights
|
|
||||||
clear-highlights
|
|
||||||
show-optimization-coach
|
|
||||||
hide-optimization-coach
|
|
||||||
get-filters
|
|
||||||
set-filters!
|
|
||||||
get-profile-file
|
|
||||||
set-profile-file!
|
|
||||||
optimization-coach-visible?
|
|
||||||
build-optimization-coach-popup-menu
|
|
||||||
launch-optimization-coach
|
|
||||||
close-optimization-coach
|
|
||||||
optimization-coach-profile
|
|
||||||
launch-profile)
|
|
||||||
|
|
||||||
(define optimization-coach-drracket-button
|
|
||||||
(list
|
|
||||||
"Optimization Coach"
|
|
||||||
optimization-coach-bitmap
|
|
||||||
(lambda (drr-frame) (send drr-frame launch-optimization-coach))))
|
|
||||||
|
|
||||||
(define-unit tool@
|
|
||||||
|
|
||||||
(import drracket:tool^)
|
|
||||||
(export drracket:tool-exports^)
|
|
||||||
|
|
||||||
(define (phase1) (void))
|
|
||||||
(define (phase2) (void))
|
|
||||||
|
|
||||||
(define highlights-mixin
|
|
||||||
(mixin (text:basic<%> drracket:unit:definitions-text<%>) ()
|
|
||||||
(inherit highlight-range unhighlight-range
|
|
||||||
get-tab get-canvas get-pos/text
|
|
||||||
position-line line-end-position
|
|
||||||
begin-edit-sequence end-edit-sequence
|
|
||||||
get-port-name)
|
|
||||||
|
|
||||||
(define highlights '()) ; (listof `(,start ,end ,popup-fun))
|
|
||||||
(define clear-thunks '()) ; list of thunks that clear highlights
|
|
||||||
(define color-table #f)
|
|
||||||
|
|
||||||
;; filters : Listof (sub-report-entry -> Bool)
|
|
||||||
;; If any of these predicates return true for a given log entry's
|
|
||||||
;; sub, show it.
|
|
||||||
;; Note: at the point where these are called, report entries have
|
|
||||||
;; a single sub.
|
|
||||||
(define filters (map cdr check-boxes)) ; all enabled by default
|
|
||||||
(define/public (get-filters) filters)
|
|
||||||
(define/public (set-filters! fs) (set! filters fs))
|
|
||||||
|
|
||||||
;; profile-file : String
|
|
||||||
;; Name of the file where profile information should be found.
|
|
||||||
;; Entered by the user, defaults to $PROGRAM.rkt.profile
|
|
||||||
;; Stored here because this info belongs to individual buffers.
|
|
||||||
;; Initialized lazily because `get-port-name' returns undefined if
|
|
||||||
;; called at editor initialization time.
|
|
||||||
(define profile-file #f)
|
|
||||||
;; TODO If I start with unsaved file, open OC, then open a file (reuses
|
|
||||||
;; same buffer), filename is not updated.
|
|
||||||
(define/public (get-profile-file)
|
|
||||||
(or profile-file
|
|
||||||
(let ([pf (string-append (format "~a" (get-port-name))
|
|
||||||
".profile")])
|
|
||||||
(set! profile-file pf)
|
|
||||||
pf))
|
|
||||||
profile-file)
|
|
||||||
(define/public (set-profile-file! pf) (set! profile-file pf))
|
|
||||||
|
|
||||||
;; highlight-range, for ranges that span multiple lines, highlights
|
|
||||||
;; to the end of the first n-1 lines. Since the space at end of lines
|
|
||||||
;; does not have editor positions, I can't figure out how to make the
|
|
||||||
;; popup menu appear there (I can only make it appear in places that
|
|
||||||
;; have positions). To work around that, we highlight only the code
|
|
||||||
;; proper, not the space at the end of lines. That way, everywhere in
|
|
||||||
;; the highlight has a position, and can spawn popup menus.
|
|
||||||
(define/private (highlight-entry l)
|
|
||||||
(match-define (report-entry subs start end badness) l)
|
|
||||||
(define color (if (= badness 0)
|
|
||||||
"lightgreen"
|
|
||||||
(vector-ref color-table badness)))
|
|
||||||
(define (highlight-part start end)
|
|
||||||
(highlight-range start end color #f 'high))
|
|
||||||
;; record highlight for popup menus
|
|
||||||
(set! highlights (cons (list start end (popup-callback l))
|
|
||||||
highlights))
|
|
||||||
(let loop ([start start])
|
|
||||||
(define line (position-line start))
|
|
||||||
(define end-of-line (line-end-position line))
|
|
||||||
(cond [(>= end-of-line end)
|
|
||||||
(list (highlight-part start end))] ; done
|
|
||||||
[else
|
|
||||||
(cons (highlight-part start end-of-line)
|
|
||||||
(loop (add1 end-of-line)))])))
|
|
||||||
|
|
||||||
(define on? #f)
|
|
||||||
(define/public (optimization-coach-visible?) on?)
|
|
||||||
|
|
||||||
(define report-cache #f)
|
|
||||||
;; source is either a copy of the definitions text (we're not in the
|
|
||||||
;; main thread, so operating on the definitions directly is a bad idea)
|
|
||||||
;; or #f, in which case the report cache is used.
|
|
||||||
;; profile is either a list of analyzed profile nodes (in which case we
|
|
||||||
;; use it to refine the report) or #f. Profile information causes the
|
|
||||||
;; report to be recomputed, invalidating the cache.
|
|
||||||
(define/public (add-highlights #:source [source #f]
|
|
||||||
#:profile [profile #f])
|
|
||||||
(clear-highlights)
|
|
||||||
(unless (and report-cache (not source) (not profile))
|
|
||||||
(set! report-cache (generate-report source profile)))
|
|
||||||
(define report
|
|
||||||
(locality-merging
|
|
||||||
(for/list ([entry (in-list report-cache)]
|
|
||||||
;; At this point, report enties have a single sub.
|
|
||||||
#:when (for/or ([f (in-list filters)])
|
|
||||||
(f (first (report-entry-subs entry)))))
|
|
||||||
entry)))
|
|
||||||
(define max-badness
|
|
||||||
(apply max (cons 0 (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)))
|
|
||||||
(begin-edit-sequence)
|
|
||||||
(set! clear-thunks (for/fold ([res '()])
|
|
||||||
([r (in-list report)])
|
|
||||||
(append (highlight-entry r) res)))
|
|
||||||
(end-edit-sequence)
|
|
||||||
(set! on? #t))
|
|
||||||
|
|
||||||
(define/public (clear-highlights)
|
|
||||||
(for ([h (in-list clear-thunks)]) (h))
|
|
||||||
(set! highlights '())
|
|
||||||
(set! on? #f))
|
|
||||||
|
|
||||||
(define (clear-and-close)
|
|
||||||
(when on?
|
|
||||||
(send+ this (get-tab) (get-frame) (close-optimization-coach))))
|
|
||||||
(define/augment (on-insert start len)
|
|
||||||
(clear-and-close)
|
|
||||||
(inner #f on-insert start len))
|
|
||||||
(define/augment (on-delete start len)
|
|
||||||
(clear-and-close)
|
|
||||||
(inner #f on-delete start len))
|
|
||||||
|
|
||||||
(define/public (build-optimization-coach-popup-menu menu pos text)
|
|
||||||
(and pos
|
|
||||||
(is-a? text text%)
|
|
||||||
;; pos is in a highlight
|
|
||||||
(for/fold ([new-item #f])
|
|
||||||
([h (in-list highlights)])
|
|
||||||
(match-define `(,start ,end ,popup-fun) h)
|
|
||||||
(or new-item
|
|
||||||
(and (<= start pos end)
|
|
||||||
(new separator-menu-item% [parent menu])
|
|
||||||
(new menu-item%
|
|
||||||
[label "Show Optimization Info"]
|
|
||||||
[parent menu]
|
|
||||||
[callback (lambda _
|
|
||||||
(popup-fun text start end))]))))))
|
|
||||||
|
|
||||||
;; gather profiling information, and use it to generate a refined report
|
|
||||||
(define/public (optimization-coach-profile source)
|
|
||||||
(if (file-exists? profile-file)
|
|
||||||
(add-highlights
|
|
||||||
#:source source
|
|
||||||
#:profile (generate-profile this source profile-file))
|
|
||||||
(message-box "Optimization Coach"
|
|
||||||
(format "Profile file not found: ~a" profile-file)
|
|
||||||
#f
|
|
||||||
'(ok stop))))
|
|
||||||
|
|
||||||
(super-new)))
|
|
||||||
|
|
||||||
(drracket:get/extend:extend-definitions-text highlights-mixin)
|
|
||||||
|
|
||||||
(define frame-mixin
|
|
||||||
(mixin (drracket:unit:frame<%>) ()
|
|
||||||
(inherit set-show-menu-sort-key get-current-tab
|
|
||||||
get-definitions-text get-interactions-text get-area-container)
|
|
||||||
|
|
||||||
|
|
||||||
;; view menu
|
|
||||||
(define/public (get-optimization-coach-menu-item)
|
|
||||||
optimization-coach-menu-item)
|
|
||||||
(define/override (add-show-menu-items show-menu)
|
|
||||||
(super add-show-menu-items show-menu)
|
|
||||||
(set! optimization-coach-menu-item
|
|
||||||
(new menu-item%
|
|
||||||
[label (string-constant show-optimization-coach)]
|
|
||||||
[parent show-menu]
|
|
||||||
[demand-callback
|
|
||||||
(λ (item)
|
|
||||||
(send item set-label
|
|
||||||
(if (send (get-definitions-text)
|
|
||||||
optimization-coach-visible?)
|
|
||||||
(string-constant hide-optimization-coach)
|
|
||||||
(string-constant show-optimization-coach))))]
|
|
||||||
[callback
|
|
||||||
(λ (a b)
|
|
||||||
(define defs (get-definitions-text))
|
|
||||||
(if (send defs optimization-coach-visible?)
|
|
||||||
(close-optimization-coach)
|
|
||||||
(launch-optimization-coach)))]))
|
|
||||||
(set-show-menu-sort-key optimization-coach-menu-item 403))
|
|
||||||
(define optimization-coach-menu-item #f)
|
|
||||||
|
|
||||||
|
|
||||||
;; right-click menu
|
|
||||||
(keymap:add-to-right-button-menu
|
|
||||||
(let ([old (keymap:add-to-right-button-menu)])
|
|
||||||
(lambda (menu editor event)
|
|
||||||
(let-values ([(pos text) (send editor get-pos/text event)])
|
|
||||||
(when (is-a? editor drracket:unit:definitions-text<%>)
|
|
||||||
;; has the optimization-coach mixin
|
|
||||||
(send editor build-optimization-coach-popup-menu
|
|
||||||
menu pos text)))
|
|
||||||
(old menu editor event))))
|
|
||||||
|
|
||||||
|
|
||||||
;; control panel
|
|
||||||
(define panel #f)
|
|
||||||
(define check-box-panel #f)
|
|
||||||
(define profile-panel #f)
|
|
||||||
(define profile-file-field #f)
|
|
||||||
(define (create-panel)
|
|
||||||
(set! panel
|
|
||||||
(new vertical-panel%
|
|
||||||
[parent (get-area-container)]
|
|
||||||
[stretchable-height #f]))
|
|
||||||
(set! check-box-panel
|
|
||||||
(new horizontal-panel%
|
|
||||||
[parent panel]
|
|
||||||
[stretchable-height #f]))
|
|
||||||
(set! profile-panel
|
|
||||||
(new horizontal-panel%
|
|
||||||
[parent panel]
|
|
||||||
[stretchable-height #f]))
|
|
||||||
(new button%
|
|
||||||
[label (string-constant close)]
|
|
||||||
[parent check-box-panel]
|
|
||||||
[callback (lambda _ (close-optimization-coach))])
|
|
||||||
(new button%
|
|
||||||
[label "Refine"]
|
|
||||||
[parent profile-panel]
|
|
||||||
[callback (lambda _ (launch-profile))])
|
|
||||||
(set! profile-file-field
|
|
||||||
(new text-field%
|
|
||||||
[label "Profile file:"]
|
|
||||||
[parent profile-panel]
|
|
||||||
[init-value (send (get-definitions-text) get-profile-file)]
|
|
||||||
[callback ; when the value changes, propagate to master
|
|
||||||
(lambda (text-field control-event)
|
|
||||||
(send (get-definitions-text) set-profile-file!
|
|
||||||
(send text-field get-value)))]))
|
|
||||||
(new button%
|
|
||||||
[label (string-constant browse...)]
|
|
||||||
[parent profile-panel]
|
|
||||||
[callback
|
|
||||||
(lambda _
|
|
||||||
(define-values (dir name _)
|
|
||||||
(split-path
|
|
||||||
(build-path (send profile-file-field get-value))))
|
|
||||||
(define f (get-file #f #f dir))
|
|
||||||
(when f
|
|
||||||
(define fn (path->string f))
|
|
||||||
(send profile-file-field set-value fn)
|
|
||||||
(send (get-definitions-text) set-profile-file! fn)))])
|
|
||||||
(for ([(l f) (in-pairs check-boxes)])
|
|
||||||
(new check-box%
|
|
||||||
[label l]
|
|
||||||
[parent check-box-panel]
|
|
||||||
[callback
|
|
||||||
(lambda _
|
|
||||||
(define definitions (get-definitions-text))
|
|
||||||
(define filters (send definitions get-filters))
|
|
||||||
(send definitions set-filters! (if (memq f filters)
|
|
||||||
(remq f filters)
|
|
||||||
(cons f filters)))
|
|
||||||
;; redraw
|
|
||||||
(send definitions add-highlights))]
|
|
||||||
[value #f]))) ; will be updated in `show-optimization-coach'
|
|
||||||
|
|
||||||
(define/public (show-optimization-coach)
|
|
||||||
(define area-container (get-area-container))
|
|
||||||
(cond [panel (or (memq panel (send area-container get-children))
|
|
||||||
(send area-container add-child panel))]
|
|
||||||
[else (create-panel)])
|
|
||||||
;; update check-boxes
|
|
||||||
(define filters (send (get-definitions-text) get-filters))
|
|
||||||
(for ([c (in-list (for/list ([c (in-list (send check-box-panel
|
|
||||||
get-children))]
|
|
||||||
#:when (is-a? c check-box%))
|
|
||||||
c))]
|
|
||||||
[(l f) (in-pairs check-boxes)])
|
|
||||||
(send c set-value (memq f filters)))
|
|
||||||
;; update profile-file-field
|
|
||||||
(send profile-file-field set-value
|
|
||||||
(send (get-definitions-text) get-profile-file)))
|
|
||||||
|
|
||||||
(define/public (hide-optimization-coach)
|
|
||||||
(send (get-area-container) delete-child panel))
|
|
||||||
|
|
||||||
|
|
||||||
;; tab switching
|
|
||||||
(define/augment (on-tab-change old-tab new-tab)
|
|
||||||
(when (send (send old-tab get-defs) optimization-coach-visible?)
|
|
||||||
(hide-optimization-coach))
|
|
||||||
(when (send (send new-tab get-defs) optimization-coach-visible?)
|
|
||||||
;; if it was open before
|
|
||||||
(show-optimization-coach))
|
|
||||||
(inner #f on-tab-change old-tab new-tab))
|
|
||||||
|
|
||||||
|
|
||||||
;; sets up definitions copying, separate thread, error handling, etc.
|
|
||||||
(define (launch-operation callback)
|
|
||||||
(define definitions (get-definitions-text))
|
|
||||||
(define interactions (get-interactions-text))
|
|
||||||
;; copy contents of the definitions window before handing control back
|
|
||||||
;; to the event loop
|
|
||||||
(define definitions-copy (copy-definitions definitions))
|
|
||||||
(send this update-running #t)
|
|
||||||
(thread ; do the work in a separate thread, to avoid blocking the GUI
|
|
||||||
(lambda ()
|
|
||||||
(with-handlers
|
|
||||||
([(lambda (e) (and (exn? e) (not (exn:break? e))))
|
|
||||||
;; something failed, report in the interactions window
|
|
||||||
(lambda (e)
|
|
||||||
(close-optimization-coach)
|
|
||||||
(send interactions reset-console)
|
|
||||||
(send interactions run-in-evaluation-thread
|
|
||||||
(lambda () (raise e))))])
|
|
||||||
(callback definitions-copy))
|
|
||||||
(send this update-running #f))))
|
|
||||||
|
|
||||||
;; entry point
|
|
||||||
(define/public (launch-optimization-coach)
|
|
||||||
(launch-operation
|
|
||||||
(lambda (definitions-copy)
|
|
||||||
(show-optimization-coach)
|
|
||||||
(send (get-definitions-text) add-highlights
|
|
||||||
#:source definitions-copy))))
|
|
||||||
|
|
||||||
(define/public (launch-profile)
|
|
||||||
(launch-operation
|
|
||||||
(lambda (definitions-copy)
|
|
||||||
(send (get-definitions-text) optimization-coach-profile
|
|
||||||
definitions-copy))))
|
|
||||||
|
|
||||||
(define/public (close-optimization-coach)
|
|
||||||
(hide-optimization-coach)
|
|
||||||
(send (get-definitions-text) clear-highlights))
|
|
||||||
|
|
||||||
(super-new)))
|
|
||||||
|
|
||||||
(drracket:get/extend:extend-unit-frame frame-mixin))
|
|
||||||
|
|
@ -1,75 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
;; Typed Racket-specific optimization analysis.
|
|
||||||
|
|
||||||
(require racket/match
|
|
||||||
"structs.rkt" "causality-merging.rkt" "profiling.rkt")
|
|
||||||
|
|
||||||
(provide report-typed-racket)
|
|
||||||
|
|
||||||
(define (report-typed-racket TR-log profile hot-functions)
|
|
||||||
(log->report
|
|
||||||
(causality-merging
|
|
||||||
(prune-cold-TR-failures TR-log profile hot-functions))))
|
|
||||||
|
|
||||||
;; Returns a report-entry or #f, which means prune.
|
|
||||||
(define (log-entry->report-entry l)
|
|
||||||
(match l
|
|
||||||
[(log-entry kind msg stx located-stx (? number? pos))
|
|
||||||
(define start (sub1 pos))
|
|
||||||
(define end (+ start (syntax-span stx)))
|
|
||||||
(define provenance 'typed-racket)
|
|
||||||
;; When we first create report entries, they have a single sub.
|
|
||||||
(report-entry (list (if (opt-log-entry? l)
|
|
||||||
(opt-report-entry located-stx msg provenance)
|
|
||||||
(missed-opt-report-entry
|
|
||||||
located-stx msg provenance
|
|
||||||
(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
|
|
||||||
|
|
||||||
;; converts log-entry structs to report-entry structs for further
|
|
||||||
;; processing
|
|
||||||
(define (log->report log)
|
|
||||||
(filter values (map log-entry->report-entry log)))
|
|
||||||
|
|
||||||
;;--------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define (prune-cold-TR-failures TR-log profile hot-functions)
|
|
||||||
(define total-time (and profile (profile-total-time profile)))
|
|
||||||
|
|
||||||
;; #f if no profiling info is available for this function
|
|
||||||
(define (pos->node pos)
|
|
||||||
(and profile
|
|
||||||
pos
|
|
||||||
(for/first ([p (in-list (profile-nodes profile))]
|
|
||||||
#:when (let* ([from (node-pos p)]
|
|
||||||
[span (node-span p)])
|
|
||||||
(and from span
|
|
||||||
(<= from pos (+ from span)))))
|
|
||||||
p)))
|
|
||||||
|
|
||||||
(if (not profile)
|
|
||||||
TR-log ; keep everything if we don't have profile info
|
|
||||||
(for/list ([l (in-list TR-log)]
|
|
||||||
#:when (or (opt-log-entry? l) ; don't prune successes
|
|
||||||
;; in hot function?
|
|
||||||
(memq (pos->node (log-entry-pos l)) hot-functions)))
|
|
||||||
(define profile-entry (memq (pos->node (log-entry-pos l)) hot-functions))
|
|
||||||
(define badness-multiplier
|
|
||||||
(if profile-entry
|
|
||||||
(/ (node-self (car profile-entry)) total-time)
|
|
||||||
1))
|
|
||||||
(match l
|
|
||||||
[(missed-opt-log-entry kind msg stx located-stx pos
|
|
||||||
irritants merged-irritants badness)
|
|
||||||
(missed-opt-log-entry kind msg stx located-stx pos
|
|
||||||
irritants merged-irritants
|
|
||||||
;; uses ceiling to never go down to 0
|
|
||||||
;; both badness and badness-multiplier are non-0
|
|
||||||
(ceiling (* badness badness-multiplier)))]
|
|
||||||
[_ l])))) ; keep as is
|
|
||||||
|
|
@ -1,6 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(provide (all-defined-out))
|
|
||||||
|
|
||||||
(define (pos-inside-us? pos our-pos our-span)
|
|
||||||
(and pos our-pos our-span (<= our-pos pos (+ our-pos our-span))))
|
|
||||||
|
|
@ -161,29 +161,8 @@ cases.
|
||||||
|
|
||||||
@subsection[#:tag "optimization-coach"]{Optimization Coaching}
|
@subsection[#:tag "optimization-coach"]{Optimization Coaching}
|
||||||
|
|
||||||
Typed Racket provides optimization coaching support to help you get the
|
The Optimization Coach package provides optimization coaching support to help
|
||||||
most of its optimizer.
|
you get the most of the Typed Racket optimizer.
|
||||||
|
|
||||||
The @deftech{Optimization Coach} DrRacket plugin can be used when editing a
|
|
||||||
Typed Racket program in DrRacket. Clicking the @bold{Optimization Coach} button
|
|
||||||
runs the optimizer and reports the results. All performed optimizations are
|
|
||||||
highlighted in green in the editor. In addition, the optimizer also reports
|
|
||||||
cases where an optimization was close to happening, but was not ultimately safe
|
|
||||||
to perform. These cases are highlighted in shades of red in the editor. The
|
|
||||||
redder the highlight, the higher the potential for optimization in the
|
|
||||||
highlighted region is.
|
|
||||||
|
|
||||||
Additional information can be accessed by right-clicking on the highlighted
|
|
||||||
regions and picking the @bold{Show Optimization Info} menu entry.
|
|
||||||
A summary of the performed optimizations and advice on how to adjust
|
|
||||||
code to make it more amenable to optimization is provided as appropriate, and
|
|
||||||
can serve as a starting point for further optimization.
|
|
||||||
|
|
||||||
Optimization Coach is also available for other Racket languages through the
|
|
||||||
@bold{Show Optimization Coach} entry in the @bold{View} menu.
|
|
||||||
When running from unytped Racket languages, Optimization Coach does not report
|
|
||||||
information about Typed Racket optimizations, and only reports information from
|
|
||||||
the Racket inliner.
|
|
||||||
|
|
||||||
Similar information (albeit without in-depth explanations or advice) is
|
Similar information (albeit without in-depth explanations or advice) is
|
||||||
available from the command line. When compiling a Typed Racket program, setting
|
available from the command line. When compiling a Typed Racket program, setting
|
||||||
|
|
@ -193,38 +172,3 @@ Racket to display performance debugging information. Setting the Racket logging
|
||||||
level can be done on the command line with the @racket[-W] flag:
|
level can be done on the command line with the @racket[-W] flag:
|
||||||
|
|
||||||
@commandline{racket -W debug my-typed-program.rkt}
|
@commandline{racket -W debug my-typed-program.rkt}
|
||||||
|
|
||||||
@subsubsection{Refining Recommendations with Profiling Information}
|
|
||||||
|
|
||||||
Given profiling information about your program, Optimization Coach can tailor
|
|
||||||
its recommendations to help you focus on the parts of your program that really
|
|
||||||
matter.
|
|
||||||
|
|
||||||
@; TODO when OC is moved to its own collect, change this, and declare exporting
|
|
||||||
@(require (for-label (only-in typed-racket/base-env/prims optimization-coach-profile)))
|
|
||||||
|
|
||||||
@defform[(optimization-coach-profile body ...)]{
|
|
||||||
To gather profiling information for use with Optimization Coach, wrap the
|
|
||||||
portion of your program that you want to profile (typically an entry point to
|
|
||||||
the program) with @racket[optimization-coach-profile].
|
|
||||||
|
|
||||||
When you next run your program, profiling information will be written to a
|
|
||||||
file, ready to be used by Optimization Coach. The output filename is
|
|
||||||
constructed by appending the @tt{.profile} suffix to the program's filename.
|
|
||||||
}
|
|
||||||
|
|
||||||
Once you have gathered profiling information, you can feed it to Optimization
|
|
||||||
Coach by specifying the profile file and clicking the @bold{Refine} button.
|
|
||||||
Optimization Coach will then reanalyze your program and produce new
|
|
||||||
recommendations.
|
|
||||||
|
|
||||||
Compared to the pre-profiling recommendations, those new recommendations should
|
|
||||||
be both more targeted and more aggressive.
|
|
||||||
Post profiling, Optimization Coach only recommends changes to functions that
|
|
||||||
had a significant impact on program performance according to profile data.
|
|
||||||
These are the functions where your tuning efforts are likely best spent.
|
|
||||||
|
|
||||||
In addition, Optimization Coach's post-profiling recommendations are more
|
|
||||||
aggressive. For example, it may recommend replacing convenient, high-level
|
|
||||||
constructs---such as structs--with more performant but lower-level ones---such
|
|
||||||
as vectors.
|
|
||||||
|
|
|
||||||
|
|
@ -11,6 +11,9 @@ typed-scheme
|
||||||
(define (make-info key default use-default)
|
(define (make-info key default use-default)
|
||||||
(case key
|
(case key
|
||||||
[(drscheme:toolbar-buttons)
|
[(drscheme:toolbar-buttons)
|
||||||
(list (dynamic-require 'typed-racket/optimizer/tool/tool
|
;; If Optimization Coach is installed, load it.
|
||||||
'optimization-coach-drracket-button))]
|
(with-handlers ([exn:fail:filesystem? (lambda _ '())]) ; not found
|
||||||
|
(collection-path "optimization-coach")
|
||||||
|
(list (dynamic-require 'optimization-coach/tool
|
||||||
|
'optimization-coach-drracket-button)))]
|
||||||
[else (use-default key default)]))
|
[else (use-default key default)]))
|
||||||
|
|
|
||||||
|
|
@ -10,8 +10,11 @@ typed/racket/base
|
||||||
(define (make-info key default use-default)
|
(define (make-info key default use-default)
|
||||||
(case key
|
(case key
|
||||||
[(drscheme:toolbar-buttons)
|
[(drscheme:toolbar-buttons)
|
||||||
(list (dynamic-require 'typed-racket/optimizer/tool/tool
|
;; If Optimization Coach is installed, load it.
|
||||||
'optimization-coach-drracket-button))]
|
(with-handlers ([exn:fail:filesystem? (lambda _ '())]) ; not found
|
||||||
|
(collection-path "optimization-coach")
|
||||||
|
(list (dynamic-require 'optimization-coach/tool
|
||||||
|
'optimization-coach-drracket-button)))]
|
||||||
[else (use-default key default)]))
|
[else (use-default key default)]))
|
||||||
|
|
||||||
(define make-language-info
|
(define make-language-info
|
||||||
|
|
|
||||||
|
|
@ -10,8 +10,11 @@ typed/racket
|
||||||
(define (make-info key default use-default)
|
(define (make-info key default use-default)
|
||||||
(case key
|
(case key
|
||||||
[(drscheme:toolbar-buttons)
|
[(drscheme:toolbar-buttons)
|
||||||
(list (dynamic-require 'typed-racket/optimizer/tool/tool
|
;; If Optimization Coach is installed, load it.
|
||||||
'optimization-coach-drracket-button))]
|
(with-handlers ([exn:fail:filesystem? (lambda _ '())]) ; not found
|
||||||
|
(collection-path "optimization-coach")
|
||||||
|
(list (dynamic-require 'optimization-coach/tool
|
||||||
|
'optimization-coach-drracket-button)))]
|
||||||
[else (use-default key default)]))
|
[else (use-default key default)]))
|
||||||
|
|
||||||
(define make-language-info
|
(define make-language-info
|
||||||
|
|
|
||||||
|
|
@ -10,8 +10,11 @@ typed/scheme/base
|
||||||
(define (make-info key default use-default)
|
(define (make-info key default use-default)
|
||||||
(case key
|
(case key
|
||||||
[(drscheme:toolbar-buttons)
|
[(drscheme:toolbar-buttons)
|
||||||
(list (dynamic-require 'typed-racket/optimizer/tool/tool
|
;; If Optimization Coach is installed, load it.
|
||||||
'optimization-coach-drracket-button))]
|
(with-handlers ([exn:fail:filesystem? (lambda _ '())]) ; not found
|
||||||
|
(collection-path "optimization-coach")
|
||||||
|
(list (dynamic-require 'optimization-coach/tool
|
||||||
|
'optimization-coach-drracket-button)))]
|
||||||
[else (use-default key default)]))
|
[else (use-default key default)]))
|
||||||
|
|
||||||
(define make-language-info
|
(define make-language-info
|
||||||
|
|
|
||||||
|
|
@ -10,8 +10,11 @@ typed/scheme
|
||||||
(define (make-info key default use-default)
|
(define (make-info key default use-default)
|
||||||
(case key
|
(case key
|
||||||
[(drscheme:toolbar-buttons)
|
[(drscheme:toolbar-buttons)
|
||||||
(list (dynamic-require 'typed-racket/optimizer/tool/tool
|
;; If Optimization Coach is installed, load it.
|
||||||
'optimization-coach-drracket-button))]
|
(with-handlers ([exn:fail:filesystem? (lambda _ '())]) ; not found
|
||||||
|
(collection-path "optimization-coach")
|
||||||
|
(list (dynamic-require 'optimization-coach/tool
|
||||||
|
'optimization-coach-drracket-button)))]
|
||||||
[else (use-default key default)]))
|
[else (use-default key default)]))
|
||||||
|
|
||||||
(define make-language-info
|
(define make-language-info
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user