From 3da04201cd81f9b392771a1d5f825662ee4ee697 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Sun, 25 Nov 2012 18:50:06 -0500 Subject: [PATCH] Move Typed Racket-specific processing to its own file. --- .../typed-racket/optimizer/tool/report.rkt | 75 +------------------ .../optimizer/tool/typed-racket.rkt | 75 +++++++++++++++++++ 2 files changed, 79 insertions(+), 71 deletions(-) create mode 100644 collects/typed-racket/optimizer/tool/typed-racket.rkt diff --git a/collects/typed-racket/optimizer/tool/report.rkt b/collects/typed-racket/optimizer/tool/report.rkt index 3c84259e4a..82f5bd55fd 100644 --- a/collects/typed-racket/optimizer/tool/report.rkt +++ b/collects/typed-racket/optimizer/tool/report.rkt @@ -1,8 +1,8 @@ #lang racket/base -(require racket/class racket/match - "structs.rkt" "instrumentation.rkt" "inlining.rkt" "hidden-costs.rkt" - "locality-merging.rkt" "causality-merging.rkt") +(require "instrumentation.rkt" "profiling.rkt" + "typed-racket.rkt" "inlining.rkt" "hidden-costs.rkt" + "locality-merging.rkt") (provide generate-report locality-merging) @@ -11,77 +11,10 @@ (define-values (TR-log mzc-log info-log) (generate-logs this)) (define hot-functions (and profile (prune-profile profile))) (append - (log->report - (causality-merging - (prune-cold-TR-failures TR-log profile hot-functions))) + (report-typed-racket TR-log profile hot-functions) (if profile ;; inlining and hidden cost reports have too low a SNR to be shown ;; w/o profiling-based pruning (append (report-inlining mzc-log profile hot-functions) (report-hidden-costs info-log profile hot-functions)) '()))) - - -;; Returns a report-entry or #f, which means prune. -(define (log-entry->report-entry l) - (match l - [(log-entry kind msg stx located-stx (? number? pos)) - (define start (sub1 pos)) - (define end (+ start (syntax-span stx))) - (define provenance 'typed-racket) - ;; When we first create report entries, they have a single sub. - (report-entry (list (if (opt-log-entry? l) - (opt-report-entry located-stx msg provenance) - (missed-opt-report-entry - located-stx msg provenance - (missed-opt-log-entry-badness l) - (missed-opt-log-entry-irritants l)))) - start end - (if (opt-log-entry? l) ; badness - 0 - (missed-opt-log-entry-badness l)))] - [_ #f])) ; no source location, ignore - -;; converts log-entry structs to report-entry structs for further -;; processing -(define (log->report log) - (filter values (map log-entry->report-entry log))) - -;;-------------------------------------------------------------------- - -(require "profiling.rkt") -(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) - (define (pos->node pos) - (and profile - pos - (for/first ([p (in-list (profile-nodes profile))] - #:when (let* ([from (node-pos p)] - [span (node-span p)]) - (and from span - (<= from pos (+ from span))))) - p))) - - (if (not profile) - TR-log ; keep everything if we don't have profile info - (for/list ([l (in-list TR-log)] - #:when (or (opt-log-entry? l) ; don't prune successes - ;; in hot function? - (memq (pos->node (log-entry-pos l)) hot-functions))) - (define profile-entry (memq (pos->node (log-entry-pos l)) hot-functions)) - (define badness-multiplier - (if profile-entry - (/ (node-self (car profile-entry)) total-time) - 1)) - (match l - [(missed-opt-log-entry kind msg stx located-stx pos - irritants merged-irritants badness) - (missed-opt-log-entry kind msg stx located-stx pos - irritants merged-irritants - ;; uses ceiling to never go down to 0 - ;; both badness and badness-multiplier are non-0 - (ceiling (* badness badness-multiplier)))] - [_ l])))) ; keep as is diff --git a/collects/typed-racket/optimizer/tool/typed-racket.rkt b/collects/typed-racket/optimizer/tool/typed-racket.rkt new file mode 100644 index 0000000000..29be475c55 --- /dev/null +++ b/collects/typed-racket/optimizer/tool/typed-racket.rkt @@ -0,0 +1,75 @@ +#lang racket/base + +;; Typed Racket-specific optimization analysis. + +(require racket/match + "structs.rkt" "causality-merging.rkt" "profiling.rkt") + +(provide report-typed-racket) + +(define (report-typed-racket TR-log profile hot-functions) + (log->report + (causality-merging + (prune-cold-TR-failures TR-log profile hot-functions)))) + +;; Returns a report-entry or #f, which means prune. +(define (log-entry->report-entry l) + (match l + [(log-entry kind msg stx located-stx (? number? pos)) + (define start (sub1 pos)) + (define end (+ start (syntax-span stx))) + (define provenance 'typed-racket) + ;; When we first create report entries, they have a single sub. + (report-entry (list (if (opt-log-entry? l) + (opt-report-entry located-stx msg provenance) + (missed-opt-report-entry + located-stx msg provenance + (missed-opt-log-entry-badness l) + (missed-opt-log-entry-irritants l)))) + start end + (if (opt-log-entry? l) ; badness + 0 + (missed-opt-log-entry-badness l)))] + [_ #f])) ; no source location, ignore + +;; converts log-entry structs to report-entry structs for further +;; processing +(define (log->report log) + (filter values (map log-entry->report-entry log))) + +;;-------------------------------------------------------------------- + +(define (prune-cold-TR-failures TR-log profile hot-functions) + (define total-time (and profile (profile-total-time profile))) + + ;; #f if no profiling info is available for this function + (define (pos->node pos) + (and profile + pos + (for/first ([p (in-list (profile-nodes profile))] + #:when (let* ([from (node-pos p)] + [span (node-span p)]) + (and from span + (<= from pos (+ from span))))) + p))) + + (if (not profile) + TR-log ; keep everything if we don't have profile info + (for/list ([l (in-list TR-log)] + #:when (or (opt-log-entry? l) ; don't prune successes + ;; in hot function? + (memq (pos->node (log-entry-pos l)) hot-functions))) + (define profile-entry (memq (pos->node (log-entry-pos l)) hot-functions)) + (define badness-multiplier + (if profile-entry + (/ (node-self (car profile-entry)) total-time) + 1)) + (match l + [(missed-opt-log-entry kind msg stx located-stx pos + irritants merged-irritants badness) + (missed-opt-log-entry kind msg stx located-stx pos + irritants merged-irritants + ;; uses ceiling to never go down to 0 + ;; both badness and badness-multiplier are non-0 + (ceiling (* badness badness-multiplier)))] + [_ l])))) ; keep as is