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

Move Typed Racket-specific processing to its own file.

Browse Source
This commit is contained in:
Vincent St-Amour 2012-11-25 18:50:06 -05:00
parent 96078c9da6
commit 3da04201cd
2 changed files with 79 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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

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

@ -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