diff --git a/pkgs/contract-profile/boundary-view.rkt b/pkgs/contract-profile/boundary-view.rkt index 79b34f4245..107bb7a8fc 100644 --- a/pkgs/contract-profile/boundary-view.rkt +++ b/pkgs/contract-profile/boundary-view.rkt @@ -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. diff --git a/pkgs/contract-profile/main.rkt b/pkgs/contract-profile/main.rkt index ce98c8bc11..a428c55535 100644 --- a/pkgs/contract-profile/main.rkt +++ b/pkgs/contract-profile/main.rkt @@ -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) diff --git a/pkgs/contract-profile/utils.rkt b/pkgs/contract-profile/utils.rkt index 3895e09838..6c37667b06 100644 --- a/pkgs/contract-profile/utils.rkt +++ b/pkgs/contract-profile/utils.rkt @@ -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))))