diff --git a/collects/typed-racket/optimizer/tool/causality-merging.rkt b/collects/typed-racket/optimizer/tool/causality-merging.rkt new file mode 100644 index 0000000000..193659b0bd --- /dev/null +++ b/collects/typed-racket/optimizer/tool/causality-merging.rkt @@ -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)])) diff --git a/collects/typed-racket/optimizer/tool/display.rkt b/collects/typed-racket/optimizer/tool/display.rkt index 7e62136d71..1da402b191 100644 --- a/collects/typed-racket/optimizer/tool/display.rkt +++ b/collects/typed-racket/optimizer/tool/display.rkt @@ -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) diff --git a/collects/typed-racket/optimizer/tool/hidden-costs.rkt b/collects/typed-racket/optimizer/tool/hidden-costs.rkt new file mode 100644 index 0000000000..ae82000f23 --- /dev/null +++ b/collects/typed-racket/optimizer/tool/hidden-costs.rkt @@ -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) diff --git a/collects/typed-racket/optimizer/tool/inlining.rkt b/collects/typed-racket/optimizer/tool/inlining.rkt new file mode 100644 index 0000000000..e643bfe638 --- /dev/null +++ b/collects/typed-racket/optimizer/tool/inlining.rkt @@ -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")) + ""))) diff --git a/collects/typed-racket/optimizer/tool/instrumentation.rkt b/collects/typed-racket/optimizer/tool/instrumentation.rkt new file mode 100644 index 0000000000..ce832a6bdb --- /dev/null +++ b/collects/typed-racket/optimizer/tool/instrumentation.rkt @@ -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 + "(" + "#\\(([^ ]+) " + "(" "#" "|" "([^ ]+)" ")" + " ([^ ]+) ([^ ]+) ([^ ]+) ([^ ]+) [^ ]+\\)" + "|" + "([^ ]+)" ; 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 # 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 # 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 # 22 14 620 335 #t)" + ".../private/map.rkt:22:14" + "#" + "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 # 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 # 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 # 35 2 838 93 #f)" + "sqr" + "#" + "/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 # 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 # 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 # 41 0 993 165 #f)" + "inC" + "#" + "/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 # 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 # 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 # 35 2 838 93 #f)" + "sqr" + "#" + "/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"))) diff --git a/collects/typed-racket/optimizer/tool/locality-merging.rkt b/collects/typed-racket/optimizer/tool/locality-merging.rkt new file mode 100644 index 0000000000..b600cf7adc --- /dev/null +++ b/collects/typed-racket/optimizer/tool/locality-merging.rkt @@ -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) diff --git a/collects/typed-racket/optimizer/tool/mzc.rkt b/collects/typed-racket/optimizer/tool/mzc.rkt deleted file mode 100644 index 89a288c7f6..0000000000 --- a/collects/typed-racket/optimizer/tool/mzc.rkt +++ /dev/null @@ -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 - "(" - "#\\(([^ ]+) " - "(" "#" "|" "([^ ]+)" ")" - " ([^ ]+) ([^ ]+) ([^ ]+) ([^ ]+) [^ ]+\\)" - "|" - "([^ ]+)" ; 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 # 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 # 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 # 22 14 620 335 #t)" - ".../private/map.rkt:22:14" - "#" - "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 # 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 # 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 # 35 2 838 93 #f)" - "sqr" - "#" - "/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 # 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 # 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 # 41 0 993 165 #f)" - "inC" - "#" - "/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 # 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 # 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 # 35 2 838 93 #f)" - "sqr" - "#" - "/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"))) diff --git a/collects/typed-racket/optimizer/tool/report.rkt b/collects/typed-racket/optimizer/tool/report.rkt index c6b019a7fe..e9edb9c8f5 100644 --- a/collects/typed-racket/optimizer/tool/report.rkt +++ b/collects/typed-racket/optimizer/tool/report.rkt @@ -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) diff --git a/collects/typed-racket/optimizer/tool/structs.rkt b/collects/typed-racket/optimizer/tool/structs.rkt new file mode 100644 index 0000000000..4b1a77c2d7 --- /dev/null +++ b/collects/typed-racket/optimizer/tool/structs.rkt @@ -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 + )) diff --git a/collects/typed-racket/optimizer/tool/tool.rkt b/collects/typed-racket/optimizer/tool/tool.rkt index 71f896913c..219fe8bab0 100644 --- a/collects/typed-racket/optimizer/tool/tool.rkt +++ b/collects/typed-racket/optimizer/tool/tool.rkt @@ -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)]) diff --git a/collects/typed-racket/optimizer/tool/utils.rkt b/collects/typed-racket/optimizer/tool/utils.rkt new file mode 100644 index 0000000000..baf5db917b --- /dev/null +++ b/collects/typed-racket/optimizer/tool/utils.rkt @@ -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))))