diff --git a/collects/typed-racket/optimizer/tool/mzc.rkt b/collects/typed-racket/optimizer/tool/mzc.rkt index 96b58ed715..776ce03acb 100644 --- a/collects/typed-racket/optimizer/tool/mzc.rkt +++ b/collects/typed-racket/optimizer/tool/mzc.rkt @@ -163,14 +163,16 @@ append (append (for/list ([group (in-list grouped-events)]) - (process-function group profile hot-functions TR-log)) + (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)) + (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 TR-log) +(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 @@ -190,6 +192,11 @@ 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? @@ -297,7 +304,9 @@ recommendation) stx located-stx pos provenance '() '() - badness))) + ;; 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 @@ -359,8 +368,8 @@ produced-entries]))) ; return the list of new entries -(define (process-profile-node profile-entry grouped-events hot-functions TR-log) - +(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))) @@ -371,6 +380,14 @@ (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))) + (when inside-hot-function? (for ([TR-entry (in-list TR-log)] #:when (info-log-entry? TR-entry) @@ -386,7 +403,7 @@ (log-entry-located-stx TR-entry) (log-entry-located-stx TR-entry) (log-entry-pos TR-entry) 'typed-racket '() '() - 20)))) ;; TODO have actual badness + parameter-access-badness)))) (when inside-hot-function? (for ([TR-entry (in-list TR-log)] @@ -404,7 +421,7 @@ (log-entry-located-stx TR-entry) (log-entry-located-stx TR-entry) (log-entry-pos TR-entry) 'typed-racket '() '() - 20)))) ;; TODO have actual badness + struct-construction-badness)))) (when inside-hot-function? (for ([TR-entry (in-list TR-log)] @@ -421,7 +438,7 @@ (log-entry-located-stx TR-entry) (log-entry-located-stx TR-entry) (log-entry-pos TR-entry) 'typed-racket '() '() - 20)))) ;; TODO have actual badness + exact-real-arith-badness)))) produced-entries) diff --git a/collects/typed-racket/optimizer/tool/report.rkt b/collects/typed-racket/optimizer/tool/report.rkt index 613f8577f8..c6b019a7fe 100644 --- a/collects/typed-racket/optimizer/tool/report.rkt +++ b/collects/typed-racket/optimizer/tool/report.rkt @@ -29,7 +29,8 @@ (define (generate-report this profile) (define-values (TR-log mzc-log) (generate-logs this)) (log->report - (append (prune-cold-TR-failures TR-log profile) + (append (prune-cold-TR-failures TR-log profile + (and profile (profile-total-time profile))) (post-process-inline-log mzc-log profile TR-log)))) @@ -217,7 +218,7 @@ ;;-------------------------------------------------------------------- (require "profiling.rkt") -(define (prune-cold-TR-failures TR-log profile) +(define (prune-cold-TR-failures TR-log profile total-time) (define hot-functions (and profile (prune-profile profile))) ;; #f if no profiling info is available for this function @@ -232,9 +233,23 @@ (<= from pos (+ from span))))) p))) - (define (in-hot-function? l) - (or (not profile) ; keep everything if we don't have profile info - (opt-log-entry? l) ; don't prune successes - (memq (pos->node (log-entry-pos l)) hot-functions))) - - (filter in-hot-function? TR-log)) + (if (not profile) + TR-log ; keep everything if we don't have profile info + (for/list ([l (in-list TR-log)] + #:when (or (opt-log-entry? l) ; don't prune successes + ;; in hot function? + (memq (pos->node (log-entry-pos l)) hot-functions))) + (define profile-entry (memq (pos->node (log-entry-pos l)) hot-functions)) + (define badness-multiplier + (if profile-entry + (/ (node-self (car profile-entry)) total-time) + 1)) + (match l + [(missed-opt-log-entry kind msg stx located-stx pos provenance + irritants merged-irritants badness) + (missed-opt-log-entry kind msg stx located-stx pos provenance + irritants merged-irritants + ;; uses ceiling to never go down to 0 + ;; both badness and badness-multiplier are non-0 + (ceiling (* badness badness-multiplier)))] + [_ l])))) ; keep as is