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

Implement path shortening when displaying contract profiles.

Browse Source
This commit is contained in:
Vincent St-Amour 2014-01-14 14:12:32 -05:00
parent 7495243d34
commit 594c3406bc
3 changed files with 83 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
pkgs/contract-profile/boundary-view.rkt
View File

@ -14,15 +14,6 @@
;; are conservative / best effort.
(define (prune-module-name name)
(define (p n) (regexp-replace #rx"^.*/" n ""))
(cond [(string? name) (p name)]
[(path? name) (p (path->string name))]
;; submodule path
[(list? name) (list 'submod
(p (path->string (first name)))
(second name))]))
;; A boundary is, at a high-level, a profile node (contracted function) and a
;; (potentially empty) set of profile edges (incoming call edges that cross the
;; contract boundary).
@ -120,8 +111,9 @@
s)))
(boundary contracted-function boundary-edges b time-spent)))
(with-output-to-report-file boundary-graph-dot-file
(render all-boundaries contracts->keys))
(with-output-to-report-file
boundary-graph-dot-file
(render all-boundaries all-blames contracts->keys))
(render-dot boundary-graph-dot-file)
;; print contract key
;; TODO find a way to add to pdf
@ -145,26 +137,17 @@
(define src (node-src node))
(and src (srcloc-source src)))
(define (node-location node)
(define (node-location node shortened-srcloc)
(define id (node-id node))
(define src (node-src node))
(format "~a~a~a"
(if id (format "~a" id) "")
(if (and id src) "\n" "")
(if src
(prune-module-name (format-source (node-src node)))
"")))
(define (summarize-boundary b contracts->keys)
(format "\n[~a] @ ~a : ~ams"
;; show the contract key
(dict-ref contracts->keys (blame-contract (boundary-blame b)))
(prune-module-name (blame-negative (boundary-blame b)))
(boundary-time b)))
(if src (format-source shortened-srcloc) "")))
;; Inspired by ../render-graphviz.rkt
(define (render all-boundaries contracts->keys)
(define (render all-boundaries all-blames contracts->keys)
(define total-contract-time
(max 1e-20 (for/sum ([b (in-list all-boundaries)]) (boundary-time b))))
@ -183,6 +166,20 @@
([e (in-list (boundary-edges b))])
(set-add nodes* (edge-caller e))))))
(define nodes->names (for/hash ([n nodes]) (values n (gensym))))
(define node->shortened-path
(make-srcloc-shortener (filter node-src nodes) ; nodes with paths only
node-src))
(define party->shortened-path
(make-shortener (set-union (map blame-positive all-blames)
(map blame-negative all-blames))))
(define (summarize-boundary b contracts->keys)
(define blame (boundary-blame b))
(format "\n[~a] @ ~a : ~ams"
;; show the contract key
(dict-ref contracts->keys (blame-contract blame))
(party->shortened-path (blame-negative blame))
(boundary-time b)))
(printf "digraph Profile {\n")
(printf "splines=\"true\"\n") ; polyline kinda works too, maybe
@ -205,7 +202,7 @@
(define label
(format
"~a\n~ams~a"
(node-location node)
(node-location node (node->shortened-path node))
(node-self node) ; raw running time (not contracts)
;; Display a summary of each boundary, which includes which contract
;; is used, the negative party and contract time spent.

10
pkgs/contract-profile/main.rkt
View File

@ -66,8 +66,10 @@
(~r (* contract-ratio total-time) #:precision 0)
total-time)
(define shorten-source
(make-srcloc-shortener all-blames blame-source))
(define (print-contract/loc c)
(printf "~a @ ~a\n" (blame-contract c) (blame-source c)))
(printf "~a @ ~a\n" (blame-contract c) (shorten-source c)))
(displayln "\nBY CONTRACT\n")
(define samples-by-contract
@ -187,10 +189,12 @@
module-graph-dot-file
(printf "digraph {\n")
(define nodes->names (for/hash ([n nodes]) (values n (gensym))))
(for ([n nodes])
(define node-labels (shorten-paths nodes))
(for ([n nodes]
[l node-labels])
(printf "~a[label=\"~a\"][color=\"~a\"]\n"
(hash-ref nodes->names n)
n
l
(if (hash-ref nodes->typed? n #f) "green" "red")))
(for ([(k v) (in-hash edge-samples)])
(match-define (cons pos neg) k)

56
pkgs/contract-profile/utils.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base
(require racket/port racket/contract)
(require racket/port racket/contract racket/list setup/collects)
(provide (all-defined-out))
@ -43,3 +43,57 @@
" source=~a>\n")
(blame-positive b) (blame-negative b)
(blame-contract b) (blame-value b) (blame-source b)))
;; (sequenceof (U path-string? submodule-path)) -> same
(define (shorten-paths ps)
;; zeroth pass, chop off submodule parts, to put back later
(define submodules ; (listof (U submodule-part #f))
(for/list ([p ps])
(and (list? p) (rest p))))
(define w/o-submodules
(for/list ([p ps])
(if (list? p) (first p) p)))
;; first pass, convert to collect relative paths if possible
(define first-pass (map path->module-path w/o-submodules))
;; second pass, make non-collect paths relative to their common ancestor
(define-values (collect-paths non-collect-paths)
(partition list? first-pass))
(define relative-paths
(if (empty? non-collect-paths) ; degenerate case
'()
(let loop ([paths (map explode-path non-collect-paths)])
(define head-base (first (first paths)))
(if (and (for/and ([p (rest paths)]) (equal? (first p) head-base))
(not (for/or ([p paths]) (empty? (rest p)))))
;; all start with the same directory, drop it
;; (and we're not dropping filenames)
(loop (map rest paths))
;; not all the same, we're done
(for/list ([p paths]) (apply build-path p))))))
;; reassemble submodule parts
(for/list ([s (in-list submodules)]
[m (in-list (append collect-paths relative-paths))])
(if s (cons m s) m)))
(define (make-shortener ps [extract-path values])
(define table
(for/hash ([p ps]
[s (shorten-paths (map extract-path ps))])
(values p s)))
(lambda (p)
(or (hash-ref table p #f)
(extract-path p))))
(define (make-srcloc-shortener srcs [extract-srcloc values])
(define table
(for/hash ([p srcs]
[s (shorten-paths (for/list ([s srcs])
(srcloc-source (extract-srcloc s))))])
(values p s)))
(lambda (p)
(define target (hash-ref table p #f))
(if target
(struct-copy srcloc
(extract-srcloc p)
[source target])
(extract-srcloc p))))