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

Major refactoring.

Browse Source
This commit is contained in:
Vincent St-Amour 2012-11-28 17:47:01 -05:00
parent ebf25a3cdb
commit 677550cbe2
11 changed files with 820 additions and 772 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
collects/typed-racket/optimizer/tool/causality-merging.rkt Normal file
View File

@ -0,0 +1,89 @@
#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 and info
;; 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)
(log-entry-provenance 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)]))

2
collects/typed-racket/optimizer/tool/display.rkt
View File

@ -2,7 +2,7 @@
(require racket/string racket/class racket/gui/base racket/match racket/port
framework syntax/to-string
"report.rkt"
"structs.rkt"
unstable/sequence unstable/pretty
images/icons/symbol)

73
collects/typed-racket/optimizer/tool/hidden-costs.rkt Normal file
View File

@ -0,0 +1,73 @@
#lang racket/base
(require "structs.rkt" "utils.rkt" "profiling.rkt")
(provide report-hidden-costs)
(define (report-hidden-costs TR-log profile hot-functions)
(apply
append
(for/list ([node (in-list (profile-nodes profile))])
(process-profile-node node hot-functions TR-log
(profile-total-time profile)))))
(define (process-profile-node profile-entry hot-functions TR-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 ([TR-entry (in-list TR-log)]
#:when (info-log-entry? TR-entry)
#:when (equal? (log-entry-kind TR-entry) kind)
#:when (inside-us? (log-entry-pos TR-entry)))
(emit (missed-opt-log-entry
"" ; kind not used at this point
message
(log-entry-located-stx TR-entry) (log-entry-located-stx TR-entry)
(log-entry-pos TR-entry) 'typed-racket
'() '()
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)

283
collects/typed-racket/optimizer/tool/inlining.rkt Normal file
View File

@ -0,0 +1,283 @@
#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-regexp (log-entry-kind l)))
(define (failure? l) (equal? failure-regexp (log-entry-kind l)))
(define (out-of-fuel? l) (equal? out-of-fuel-regexp (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 (and profile (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 provenance)
;; #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)
(and profile
(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 (emit-near-miss msg badness)
(emit (missed-opt-log-entry
kind
(format "Missed Inlining ~a\n~a~a"
(format-aggregation-string pruned-log)
(if msg (format "~a\n" msg) "")
recommendation)
stx located-stx pos provenance
'() '()
;; uses ceiling to never go down to 0
;; both badness and badness-multiplier are non-0
(ceiling (* badness badness-multiplier)))))
(define (emit-success)
(emit (opt-log-entry
kind
(format "Inlining ~a" (format-aggregation-string pruned-log))
stx located-stx pos provenance)))
(define inside-hot-function?
(and profile (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)))))
;; If we know which regions are hot, prune reports about cold
;; regions. If we don't know, err on the side of showing more.
;; We don't want to prune earlier, since traversing cold functions can
;; give us advice about hot functions.
(when (and profile
(not inside-hot-function?)
(not really-hot-anonymous-function-inside-us?))
(prune))
(cond [(and profile
(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 profile
(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"))
"")))

241
collects/typed-racket/optimizer/tool/instrumentation.rkt Normal file
View File

@ -0,0 +1,241 @@
#lang racket/base
(require racket/class racket/gui/base racket/string racket/match
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 '())
(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 (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)
(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)
(values (reverse TR-log) (reverse mzc-log)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Inlining pre-processing
(provide success-regexp failure-regexp out-of-fuel-regexp)
;;; Low-level log parsing. Goes from strings to log-entry structs.
(define success-regexp "inlining: ")
(define failure-regexp "no inlining: ")
(define out-of-fuel-regexp "no inlining, out of fuel: ")
(define any-inlining-event-regexp
(format "^optimizer: (~a)" (string-join (list success-regexp
failure-regexp
out-of-fuel-regexp)
"|")))
;; String (message from the mzc optimizer) -> log-entry
(define (mzc-opt-log-message->log-entry l)
(define evt (parse-inlining-event l))
(define forged-stx (inlining-event->forged-stx evt))
(define kind
(match (inlining-event-kind evt)
[(and k (== success-regexp)) success-regexp]
[(and k (== failure-regexp)) failure-regexp]
[(and k (== out-of-fuel-regexp)) out-of-fuel-regexp]
[_ (error "Unknown log message type" l)]))
(inliner-log-entry kind kind
forged-stx forged-stx
(syntax-position forged-stx)
'mzc
evt))
(define inlining-event-regexp
;; Last bit is `generated?'. We don't care about that.
;; The middle elements of the vector are numbers of #f.
(string-append
;; Attempt at making this thing readable.
any-inlining-event-regexp
"involving: "
;; _What_ gets inlined (or not).
(string-append ; either a vector with name and source info, or just name
"("
"#\\(([^ ]+) "
"(" "#<path:(.+)>" "|" "([^ ]+)" ")"
" ([^ ]+) ([^ ]+) ([^ ]+) ([^ ]+) [^ ]+\\)"
"|"
"([^ ]+)" ; just name, we won't be able to do much with it
")")
;; _Where_ this happens (in which function, can't get more precise info).
(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: [^ ]+)?")
" size: ([^ ]+) threshold: ([^ ]+)"
"$"))
(define (parse-inlining-event l)
(match (regexp-match inlining-event-regexp l)
[`(,all ,kind
,what ,name ,path ,file-path ,unsaved-path ,line ,col ,pos ,span
,only-name
,where ,where-loc ,where-path ,where-line ,where-col ,where-name
,maybe-module-info
,size ,threshold)
(inlining-event kind
(string->symbol (or name only-name))
(if only-name
#f ; no source location
(list (or file-path unsaved-path)
(string->number line)
(string->number col)
(string->number pos)
(string->number span)))
where-name
(if where-loc
(list where-path
(string->number where-line)
(string->number where-col))
#f) ; no source location
(string->number size)
(string->number threshold))]
[_ (error "ill-formed inlining log entry" l)]))
(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
(define (parse l) (regexp-match inlining-event-regexp l))
;; Windows path
(check-equal? (parse "optimizer: no inlining, out of fuel: involving: #(.../private/map.rkt:22:14 #<path:C:\\Users\\bernardip\\Documents\\Local\\RacketPortable\\App\\Racket\\collects\\racket\\private\\map.rkt> 22 14 620 335 #t) in: C:\\Users\\bernardip\\Documents\\Scheme\\fotografia.rkt:23:0: prova2 in module: 'anonymous-module size: 55 threshold: 8")
'("optimizer: no inlining, out of fuel: involving: #(.../private/map.rkt:22:14 #<path:C:\\Users\\bernardip\\Documents\\Local\\RacketPortable\\App\\Racket\\collects\\racket\\private\\map.rkt> 22 14 620 335 #t) in: C:\\Users\\bernardip\\Documents\\Scheme\\fotografia.rkt:23:0: prova2 in module: 'anonymous-module size: 55 threshold: 8"
"no inlining, 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)"
".../private/map.rkt:22:14"
"#<path:C:\\Users\\bernardip\\Documents\\Local\\RacketPortable\\App\\Racket\\collects\\racket\\private\\map.rkt>"
"C:\\Users\\bernardip\\Documents\\Local\\RacketPortable\\App\\Racket\\collects\\racket\\private\\map.rkt"
#f
"22"
"14"
"620"
"335"
#f
" in: C:\\Users\\bernardip\\Documents\\Scheme\\fotografia.rkt:23:0: prova2"
"C:\\Users\\bernardip\\Documents\\Scheme\\fotografia.rkt:23:0: "
"C:\\Users\\bernardip\\Documents\\Scheme\\fotografia.rkt"
"23"
"0"
"prova2"
" in module: 'anonymous-module"
"55"
"8"))
(check-equal? (parse "optimizer: no inlining, out of fuel: involving: #(sqr #<path:/home/stamourv/src/plt/collects/racket/math.rkt> 35 2 838 93 #f) in: /home/stamourv/src/examples/example-shapes.rkt:41:0: inC in module: 'example-shapes size: 21 threshold: 6")
'("optimizer: no inlining, out of fuel: involving: #(sqr #<path:/home/stamourv/src/plt/collects/racket/math.rkt> 35 2 838 93 #f) in: /home/stamourv/src/examples/example-shapes.rkt:41:0: inC in module: 'example-shapes size: 21 threshold: 6"
"no inlining, out of fuel: "
"#(sqr #<path:/home/stamourv/src/plt/collects/racket/math.rkt> 35 2 838 93 #f)"
"sqr"
"#<path:/home/stamourv/src/plt/collects/racket/math.rkt>"
"/home/stamourv/src/plt/collects/racket/math.rkt"
#f
"35"
"2"
"838"
"93"
#f
" in: /home/stamourv/src/examples/example-shapes.rkt:41:0: inC"
"/home/stamourv/src/examples/example-shapes.rkt:41:0: "
"/home/stamourv/src/examples/example-shapes.rkt"
"41"
"0"
"inC"
" in module: 'example-shapes"
"21"
"6"))
(check-equal? (parse "optimizer: inlining: involving: #(inC #<path:/home/stamourv/src/examples/example-shapes.rkt> 41 0 993 165 #f) in: /home/stamourv/src/examples/example-shapes.rkt:27:0: in in module: 'example-shapes size: 41 threshold: 128")
'("optimizer: inlining: involving: #(inC #<path:/home/stamourv/src/examples/example-shapes.rkt> 41 0 993 165 #f) in: /home/stamourv/src/examples/example-shapes.rkt:27:0: in in module: 'example-shapes size: 41 threshold: 128"
"inlining: "
"#(inC #<path:/home/stamourv/src/examples/example-shapes.rkt> 41 0 993 165 #f)"
"inC"
"#<path:/home/stamourv/src/examples/example-shapes.rkt>"
"/home/stamourv/src/examples/example-shapes.rkt"
#f
"41"
"0"
"993"
"165"
#f
" in: /home/stamourv/src/examples/example-shapes.rkt:27:0: in"
"/home/stamourv/src/examples/example-shapes.rkt:27:0: "
"/home/stamourv/src/examples/example-shapes.rkt"
"27"
"0"
"in"
" in module: 'example-shapes"
"41"
"128"))
(check-equal? (parse "optimizer: no inlining, out of fuel: involving: #(sqr #<path:/Applications/Racket v5.3/collects/racket/math.rkt> 35 2 838 93 #f) in: /Users/user/Desktop/Optimization Coach/example-shapes.rkt:41:0: inC in module: 'anonymous-module size: 21 threshold: 6")
'("optimizer: no inlining, out of fuel: involving: #(sqr #<path:/Applications/Racket v5.3/collects/racket/math.rkt> 35 2 838 93 #f) in: /Users/user/Desktop/Optimization Coach/example-shapes.rkt:41:0: inC in module: 'anonymous-module size: 21 threshold: 6"
"no inlining, out of fuel: "
"#(sqr #<path:/Applications/Racket v5.3/collects/racket/math.rkt> 35 2 838 93 #f)"
"sqr"
"#<path:/Applications/Racket v5.3/collects/racket/math.rkt>"
"/Applications/Racket v5.3/collects/racket/math.rkt"
#f
"35"
"2"
"838"
"93"
#f
" in: /Users/user/Desktop/Optimization Coach/example-shapes.rkt:41:0: inC"
"/Users/user/Desktop/Optimization Coach/example-shapes.rkt:41:0: "
"/Users/user/Desktop/Optimization Coach/example-shapes.rkt"
"41"
"0"
"inC"
" in module: 'anonymous-module"
"21"
"6")))

40
collects/typed-racket/optimizer/tool/locality-merging.rkt Normal file
View File

@ -0,0 +1,40 @@
#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)

564
collects/typed-racket/optimizer/tool/mzc.rkt
View File

@ -1,564 +0,0 @@
#lang racket/base
;;;; Processing of mzc inliner logs.
(require typed-racket/optimizer/logging
unstable/syntax racket/match unstable/match racket/list racket/string
unstable/list
"profiling.rkt")
(provide mzc-opt-log-message->log-entry
post-process-inline-log)
;;; Low-level log parsing. Goes from strings to log-entry structs.
(define success-regexp "inlining: ")
(define failure-regexp "no inlining: ")
(define out-of-fuel-regexp "no inlining, out of fuel: ")
(define any-inlining-event-regexp
(format "^optimizer: (~a)" (string-join (list success-regexp
failure-regexp
out-of-fuel-regexp)
"|")))
(struct inliner-log-entry log-entry (inlining-event) #:prefab)
;; String (message from the mzc optimizer) -> log-entry
(define (mzc-opt-log-message->log-entry l)
(define evt (parse-inlining-event l))
(define forged-stx (inlining-event->forged-stx evt))
(define kind
(match (inlining-event-kind evt)
[(and k (== success-regexp)) success-regexp]
[(and k (== failure-regexp)) failure-regexp]
[(and k (== out-of-fuel-regexp)) out-of-fuel-regexp]
[_ (error "Unknown log message type" l)]))
(inliner-log-entry kind kind
forged-stx forged-stx
(syntax-position forged-stx)
'mzc
evt))
(define inlining-event-regexp
;; Last bit is `generated?'. We don't care about that.
;; The middle elements of the vector are numbers of #f.
(string-append
;; Attempt at making this thing readable.
any-inlining-event-regexp
"involving: "
;; _What_ gets inlined (or not).
(string-append ; either a vector with name and source info, or just name
"("
"#\\(([^ ]+) "
"(" "#<path:(.+)>" "|" "([^ ]+)" ")"
" ([^ ]+) ([^ ]+) ([^ ]+) ([^ ]+) [^ ]+\\)"
"|"
"([^ ]+)" ; just name, we won't be able to do much with it
")")
;; _Where_ this happens (in which function, can't get more precise info).
(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: [^ ]+)?")
" size: ([^ ]+) threshold: ([^ ]+)"
"$"))
(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
))
(define (parse-inlining-event l)
(match (regexp-match inlining-event-regexp l)
[`(,all ,kind
,what ,name ,path ,file-path ,unsaved-path ,line ,col ,pos ,span
,only-name
,where ,where-loc ,where-path ,where-line ,where-col ,where-name
,maybe-module-info
,size ,threshold)
(inlining-event kind
(string->symbol (or name only-name))
(if only-name
#f ; no source location
(list (or file-path unsaved-path)
(string->number line)
(string->number col)
(string->number pos)
(string->number span)))
where-name
(if where-loc
(list where-path
(string->number where-line)
(string->number where-col))
#f) ; no source location
(string->number size)
(string->number threshold))]
[_ (error "ill-formed inlining log entry" l)]))
(define (inlining-event->forged-stx evt)
(match evt
[(inlining-event kind name loc where-name where-loc size threshold)
(datum->syntax #'here name loc)]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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-regexp (log-entry-kind l)))
(define (failure? l) (equal? failure-regexp (log-entry-kind l)))
(define (out-of-fuel? l) (equal? out-of-fuel-regexp (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
))
;; We aggregate results for each function.
;; Log messages produced by the inliner are very raw, unlike the TR logs,
;; which have gone through some aggregation. We do the aggregation here.
(define (post-process-inline-log log profile TR-log)
(define hot-functions (and profile (prune-profile profile)))
(define grouped-events
(group-by equal? #:key log-entry-pos log)) ; right file, so that's enough
(apply
append
(append
(for/list ([group (in-list grouped-events)])
(process-function group profile hot-functions
(and profile (profile-total-time profile))))
(if profile
(for/list ([node (in-list (profile-nodes profile))])
(process-profile-node node grouped-events hot-functions TR-log
(profile-total-time profile)))
'()))))
;; Process the inlining logs corresponding to a single function.
(define (process-function log profile hot-functions total-time)
(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 provenance)
;; #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)
(and profile
(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 (emit-near-miss msg badness)
(emit (missed-opt-log-entry
kind
(format "Missed Inlining ~a\n~a~a"
(format-aggregation-string pruned-log)
(if msg (format "~a\n" msg) "")
recommendation)
stx located-stx pos provenance
'() '()
;; uses ceiling to never go down to 0
;; both badness and badness-multiplier are non-0
(ceiling (* badness badness-multiplier)))))
(define (emit-success)
(emit (opt-log-entry
kind
(format "Inlining ~a" (format-aggregation-string pruned-log))
stx located-stx pos provenance)))
(define inside-hot-function?
(and profile (memq profile-entry hot-functions)))
(define (pos-inside-us? pos)
(define our-pos (syntax-position located-stx))
(define our-span (syntax-span located-stx))
(and pos our-pos our-span (<= our-pos pos (+ our-pos our-span))))
(define (inside-us? h)
(pos-inside-us? (node-pos h)))
;; 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)))))
;; If we know which regions are hot, prune reports about cold
;; regions. If we don't know, err on the side of showing more.
;; We don't want to prune earlier, since traversing cold functions can
;; give us advice about hot functions.
(when (and profile
(not inside-hot-function?)
(not really-hot-anonymous-function-inside-us?))
(prune))
(cond [(and profile
(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 profile
(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 (process-profile-node profile-entry grouped-events hot-functions TR-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 (pos-inside-us? pos)
(define our-pos (node-pos profile-entry))
(define our-span (node-span profile-entry))
(and pos our-pos our-span (<= our-pos pos (+ our-pos our-span))))
(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 ([TR-entry (in-list TR-log)]
#:when (info-log-entry? TR-entry)
#:when (equal? (log-entry-kind TR-entry) kind)
#:when (pos-inside-us? (log-entry-pos TR-entry)))
(emit (missed-opt-log-entry
"" ; kind not used at this point
message
(log-entry-located-stx TR-entry) (log-entry-located-stx TR-entry)
(log-entry-pos TR-entry) 'typed-racket
'() '()
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)
(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"))
"")))
(module+ test
(require rackunit)
;; log parsing tests
(define (parse l) (regexp-match inlining-event-regexp l))
;; Windows path
(check-equal? (parse "optimizer: no inlining, out of fuel: involving: #(.../private/map.rkt:22:14 #<path:C:\\Users\\bernardip\\Documents\\Local\\RacketPortable\\App\\Racket\\collects\\racket\\private\\map.rkt> 22 14 620 335 #t) in: C:\\Users\\bernardip\\Documents\\Scheme\\fotografia.rkt:23:0: prova2 in module: 'anonymous-module size: 55 threshold: 8")
'("optimizer: no inlining, out of fuel: involving: #(.../private/map.rkt:22:14 #<path:C:\\Users\\bernardip\\Documents\\Local\\RacketPortable\\App\\Racket\\collects\\racket\\private\\map.rkt> 22 14 620 335 #t) in: C:\\Users\\bernardip\\Documents\\Scheme\\fotografia.rkt:23:0: prova2 in module: 'anonymous-module size: 55 threshold: 8"
"no inlining, 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)"
".../private/map.rkt:22:14"
"#<path:C:\\Users\\bernardip\\Documents\\Local\\RacketPortable\\App\\Racket\\collects\\racket\\private\\map.rkt>"
"C:\\Users\\bernardip\\Documents\\Local\\RacketPortable\\App\\Racket\\collects\\racket\\private\\map.rkt"
#f
"22"
"14"
"620"
"335"
#f
" in: C:\\Users\\bernardip\\Documents\\Scheme\\fotografia.rkt:23:0: prova2"
"C:\\Users\\bernardip\\Documents\\Scheme\\fotografia.rkt:23:0: "
"C:\\Users\\bernardip\\Documents\\Scheme\\fotografia.rkt"
"23"
"0"
"prova2"
" in module: 'anonymous-module"
"55"
"8"))
(check-equal? (parse "optimizer: no inlining, out of fuel: involving: #(sqr #<path:/home/stamourv/src/plt/collects/racket/math.rkt> 35 2 838 93 #f) in: /home/stamourv/src/examples/example-shapes.rkt:41:0: inC in module: 'example-shapes size: 21 threshold: 6")
'("optimizer: no inlining, out of fuel: involving: #(sqr #<path:/home/stamourv/src/plt/collects/racket/math.rkt> 35 2 838 93 #f) in: /home/stamourv/src/examples/example-shapes.rkt:41:0: inC in module: 'example-shapes size: 21 threshold: 6"
"no inlining, out of fuel: "
"#(sqr #<path:/home/stamourv/src/plt/collects/racket/math.rkt> 35 2 838 93 #f)"
"sqr"
"#<path:/home/stamourv/src/plt/collects/racket/math.rkt>"
"/home/stamourv/src/plt/collects/racket/math.rkt"
#f
"35"
"2"
"838"
"93"
#f
" in: /home/stamourv/src/examples/example-shapes.rkt:41:0: inC"
"/home/stamourv/src/examples/example-shapes.rkt:41:0: "
"/home/stamourv/src/examples/example-shapes.rkt"
"41"
"0"
"inC"
" in module: 'example-shapes"
"21"
"6"))
(check-equal? (parse "optimizer: inlining: involving: #(inC #<path:/home/stamourv/src/examples/example-shapes.rkt> 41 0 993 165 #f) in: /home/stamourv/src/examples/example-shapes.rkt:27:0: in in module: 'example-shapes size: 41 threshold: 128")
'("optimizer: inlining: involving: #(inC #<path:/home/stamourv/src/examples/example-shapes.rkt> 41 0 993 165 #f) in: /home/stamourv/src/examples/example-shapes.rkt:27:0: in in module: 'example-shapes size: 41 threshold: 128"
"inlining: "
"#(inC #<path:/home/stamourv/src/examples/example-shapes.rkt> 41 0 993 165 #f)"
"inC"
"#<path:/home/stamourv/src/examples/example-shapes.rkt>"
"/home/stamourv/src/examples/example-shapes.rkt"
#f
"41"
"0"
"993"
"165"
#f
" in: /home/stamourv/src/examples/example-shapes.rkt:27:0: in"
"/home/stamourv/src/examples/example-shapes.rkt:27:0: "
"/home/stamourv/src/examples/example-shapes.rkt"
"27"
"0"
"in"
" in module: 'example-shapes"
"41"
"128"))
(check-equal? (parse "optimizer: no inlining, out of fuel: involving: #(sqr #<path:/Applications/Racket v5.3/collects/racket/math.rkt> 35 2 838 93 #f) in: /Users/user/Desktop/Optimization Coach/example-shapes.rkt:41:0: inC in module: 'anonymous-module size: 21 threshold: 6")
'("optimizer: no inlining, out of fuel: involving: #(sqr #<path:/Applications/Racket v5.3/collects/racket/math.rkt> 35 2 838 93 #f) in: /Users/user/Desktop/Optimization Coach/example-shapes.rkt:41:0: inC in module: 'anonymous-module size: 21 threshold: 6"
"no inlining, out of fuel: "
"#(sqr #<path:/Applications/Racket v5.3/collects/racket/math.rkt> 35 2 838 93 #f)"
"sqr"
"#<path:/Applications/Racket v5.3/collects/racket/math.rkt>"
"/Applications/Racket v5.3/collects/racket/math.rkt"
#f
"35"
"2"
"838"
"93"
#f
" in: /Users/user/Desktop/Optimization Coach/example-shapes.rkt:41:0: inC"
"/Users/user/Desktop/Optimization Coach/example-shapes.rkt:41:0: "
"/Users/user/Desktop/Optimization Coach/example-shapes.rkt"
"41"
"0"
"inC"
" in module: 'anonymous-module"
"21"
"6")))

247
collects/typed-racket/optimizer/tool/report.rkt
View File

@ -1,225 +1,62 @@
#lang racket/base
(require racket/class racket/gui/base racket/match racket/list
unstable/syntax unstable/logging
typed-racket/optimizer/logging
"mzc.rkt" "sandbox.rkt")
(require racket/class racket/match racket/list
"structs.rkt" "instrumentation.rkt" "inlining.rkt" "hidden-costs.rkt"
"locality-merging.rkt" "causality-merging.rkt")
(provide (struct-out report-entry)
(struct-out sub-report-entry)
(struct-out opt-report-entry)
(struct-out missed-opt-report-entry)
generate-report
collapse-report)
;; 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))
(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) (generate-logs this))
(define-values (pre-TR-log mzc-log) (generate-logs this))
;; The raw TR log 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.
(define TR-log (remove-duplicates pre-TR-log))
(define hot-functions (and profile (prune-profile profile)))
(log->report
(append (prune-cold-TR-failures TR-log profile
(and profile (profile-total-time profile)))
(post-process-inline-log mzc-log profile TR-log))))
(append (causality-merging
(prune-cold-TR-failures TR-log profile hot-functions))
(report-inlining mzc-log profile hot-functions)
(if profile
(report-hidden-costs TR-log profile hot-functions)
'()))))
(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 '())
(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 (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)
(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)
(values (reverse TR-log) (reverse mzc-log)))
;; Returns a report-entry or #f, which means prune.
(define (log-entry->report-entry l)
(match l
[(? info-log-entry? _)
;; Info entries are only useful for log analysis, and should not be
;; presented to users. Drop them.
#f]
[(log-entry kind msg stx located-stx (? number? pos) provenance)
(define start (sub1 pos))
(define end (+ start (syntax-span stx)))
;; 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)
(define (log-entry->report-entry l)
(match l
[(? info-log-entry? _)
;; Info entries are only useful for log analysis, and should not be
;; presented to users. Drop them.
#f]
[(log-entry kind msg stx located-stx (? number? pos) provenance)
(define start (sub1 pos))
(define end (+ start (syntax-span stx)))
;; 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
;; We remove duplicates that were caused by traversing the same piece
;; of code multiple times in the optimizer.
(filter values
(map log-entry->report-entry
;; merge missed-opts hierarchically
(for/fold ([res '()])
([new (remove-duplicates log)])
(cond [(missed-opt-log-entry? new)
(maybe-merge-with-parent new res)]
[else
(cons new res)]))))) ; no merging for opts and info
;;--------------------------------------------------------------------
;; 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)
(log-entry-provenance 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)]))
;;--------------------------------------------------------------------
(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 (collapse-report 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)
(filter values (map log-entry->report-entry log)))
;;--------------------------------------------------------------------
(require "profiling.rkt")
(define (prune-cold-TR-failures TR-log profile total-time)
(define hot-functions (and profile (prune-profile profile)))
(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
;; takes in either a single pos number or a pair of numbers (line col)

43
collects/typed-racket/optimizer/tool/structs.rkt Normal file
View File

@ -0,0 +1,43 @@
#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
))

4
collects/typed-racket/optimizer/tool/tool.rkt
View File

@ -6,7 +6,7 @@
(for-syntax racket/base images/icons/misc images/icons/style)
string-constants)
(require "report.rkt" "profiling.rkt" "display.rkt")
(require "structs.rkt" "report.rkt" "profiling.rkt" "display.rkt")
(provide tool@ optimization-coach-drracket-button)
@ -129,7 +129,7 @@
(unless (and report-cache (not source) (not profile))
(set! report-cache (generate-report source profile)))
(define report
(collapse-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)])

6
collects/typed-racket/optimizer/tool/utils.rkt Normal file
View File

@ -0,0 +1,6 @@
#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))))