Move Optimization Coach to PLaneT 2.
This commit is contained in:
Vincent St-Amour
parent
54c8394280
commit
2c8e5f9acb
|
|
@ -259,19 +259,6 @@ appears at any time.
|
|||
@item{@defmenuitem{Hide Module Browser} Hides the 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"].}
|
||||
|
||||
|
||||
]
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ...)
|
||||
(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))))))]))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,4 @@
|
|||
#lang setup/infotab
|
||||
|
||||
(define scribblings '(("scribblings/ts-reference.scrbl" (multi-page) (language 4))
|
||||
("scribblings/ts-guide.scrbl" (multi-page) (language 5))))
|
||||
(define drracket-tools '(("optimizer/tool/tool.rkt")))
|
||||
(define drracket-tool-names '("Optimization Coach"))
|
||||
("scribblings/ts-guide.scrbl" (multi-page) (language 5))))
|
||||
|
|
|
|||
|
|
@ -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}
|
||||
|
||||
Typed Racket provides optimization coaching support to help you get the
|
||||
most of its 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.
|
||||
The Optimization Coach package provides optimization coaching support to help
|
||||
you get the most of the Typed Racket optimizer.
|
||||
|
||||
Similar information (albeit without in-depth explanations or advice) is
|
||||
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:
|
||||
|
||||
@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)
|
||||
(case key
|
||||
[(drscheme:toolbar-buttons)
|
||||
(list (dynamic-require 'typed-racket/optimizer/tool/tool
|
||||
'optimization-coach-drracket-button))]
|
||||
;; If Optimization Coach is installed, load it.
|
||||
(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)]))
|
||||
|
|
|
|||
|
|
@ -10,8 +10,11 @@ typed/racket/base
|
|||
(define (make-info key default use-default)
|
||||
(case key
|
||||
[(drscheme:toolbar-buttons)
|
||||
(list (dynamic-require 'typed-racket/optimizer/tool/tool
|
||||
'optimization-coach-drracket-button))]
|
||||
;; If Optimization Coach is installed, load it.
|
||||
(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)]))
|
||||
|
||||
(define make-language-info
|
||||
|
|
|
|||
|
|
@ -10,8 +10,11 @@ typed/racket
|
|||
(define (make-info key default use-default)
|
||||
(case key
|
||||
[(drscheme:toolbar-buttons)
|
||||
(list (dynamic-require 'typed-racket/optimizer/tool/tool
|
||||
'optimization-coach-drracket-button))]
|
||||
;; If Optimization Coach is installed, load it.
|
||||
(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)]))
|
||||
|
||||
(define make-language-info
|
||||
|
|
|
|||
|
|
@ -10,8 +10,11 @@ typed/scheme/base
|
|||
(define (make-info key default use-default)
|
||||
(case key
|
||||
[(drscheme:toolbar-buttons)
|
||||
(list (dynamic-require 'typed-racket/optimizer/tool/tool
|
||||
'optimization-coach-drracket-button))]
|
||||
;; If Optimization Coach is installed, load it.
|
||||
(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)]))
|
||||
|
||||
(define make-language-info
|
||||
|
|
|
|||
|
|
@ -10,8 +10,11 @@ typed/scheme
|
|||
(define (make-info key default use-default)
|
||||
(case key
|
||||
[(drscheme:toolbar-buttons)
|
||||
(list (dynamic-require 'typed-racket/optimizer/tool/tool
|
||||
'optimization-coach-drracket-button))]
|
||||
;; If Optimization Coach is installed, load it.
|
||||
(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)]))
|
||||
|
||||
(define make-language-info
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user