147 lines
6.1 KiB
Racket
147 lines
6.1 KiB
Racket
#lang at-exp racket/base
|
|
|
|
(provide render)
|
|
|
|
(require "analyzer.rkt" "utils.rkt" racket/list racket/string)
|
|
|
|
(define (f:msec msec)
|
|
(number->string (round (inexact->exact msec))))
|
|
|
|
(define (f:msec* msec)
|
|
(string-append (f:msec msec) "ms"))
|
|
|
|
(define (display-table aligns table)
|
|
;; * thunks are used for cells that are ignored when inspecting widths
|
|
;; * chars are used for filler cells
|
|
(define (display-line strings)
|
|
(printf "~a\n" (regexp-replace #rx" +$" (string-append* strings) "")))
|
|
(define widths
|
|
(let loop ([table table])
|
|
(define table* (filter pair? table))
|
|
(if (null? table*) '()
|
|
(cons (apply max
|
|
(filter-map
|
|
(λ (x) (and (string? (car x)) (string-length (car x))))
|
|
table*))
|
|
(loop (map cdr table*))))))
|
|
(for ([row (in-list table)])
|
|
(display-line
|
|
(for/list ([cell (in-list row)]
|
|
[width (in-list widths)]
|
|
[align (in-list aligns)])
|
|
(define cell*
|
|
(cond [(char? cell) (make-string width cell)]
|
|
[(procedure? cell) (cell)]
|
|
[else cell]))
|
|
(define pad
|
|
(make-string (max 0 (- width (string-length cell*))) #\space))
|
|
(case align
|
|
[(l) (string-append cell* pad)]
|
|
[(r) (string-append pad cell*)]
|
|
[else (error 'internal-error "poof")])))))
|
|
|
|
(define (render profile
|
|
[order 'topological]
|
|
#:truncate-source [truncate-source 50]
|
|
#:hide-self [hide-self% 1/100]
|
|
#:hide-subs [hide-subs% 2/100])
|
|
(unless (member order '(topological self total))
|
|
(raise-argument-error 'render "(or/c 'topological 'self 'total)" order))
|
|
(define key (if (eq? order 'total) node-total node-self))
|
|
(define (show . xs)
|
|
(let loop ([x xs])
|
|
(cond [(or (not x) (null? x) (void? x)) (void)]
|
|
[(pair? x) (loop (car x)) (loop (cdr x))]
|
|
[else (display x)]))
|
|
(newline))
|
|
(define total-time (profile-total-time profile)) ;!! are these two
|
|
(define cpu-time (profile-cpu-time profile)) ;!! swapped?
|
|
(define sample-number (profile-sample-number profile))
|
|
(define granularity (if (zero? sample-number) 0 ;!! this might
|
|
(/ total-time sample-number))) ;!! be wrong
|
|
(define threads+times (profile-thread-times profile))
|
|
(define *-node (profile-*-node profile))
|
|
(define hidden (get-hidden profile hide-self% hide-subs%))
|
|
(define nodes (let ([incnodes (remq* hidden (profile-nodes profile))])
|
|
(if (eq? order 'topological)
|
|
incnodes
|
|
(sort incnodes > #:key key))))
|
|
(define node->
|
|
(let ([t (make-hasheq)])
|
|
(for ([node (in-list nodes)] [idx (in-naturals 1)])
|
|
(define index (format "[~a]" idx))
|
|
(define label (format "~a" (or (node-id node) '???)))
|
|
(hash-set! t node (list index label @string-append{@label @index})))
|
|
(λ (mode node)
|
|
((case mode [(index) car] [(label) cadr] [(sub-label) caddr])
|
|
(hash-ref t node)))))
|
|
(define (sep ch) (list ch ch ch ch ch ch ch ch ch ch))
|
|
(define =sep (sep #\=))
|
|
(define -sep (sep #\-))
|
|
@show{
|
|
Profiling results
|
|
-----------------
|
|
Total cpu time observed: @f:msec*[total-time] (out of @f:msec*[cpu-time])
|
|
Number of samples taken: @sample-number (once every @f:msec*[granularity])
|
|
}
|
|
(when (> (length threads+times) 1)
|
|
@show{ Threads observed: @(length threads+times)})
|
|
(when (pair? hidden)
|
|
(define hidden# (length hidden))
|
|
(define nodes# (length (profile-nodes profile)))
|
|
(define self% @string-append{self<@(format-percent (or hide-self% 0))})
|
|
(define subs% @string-append{local<@(format-percent (or hide-subs% 0))})
|
|
(define %s (cond [(not hide-self%) subs%]
|
|
[(not hide-subs%) self%]
|
|
[else @string-append{@self% and @subs%}]))
|
|
@show{ (Hiding functions with @|%s|: @hidden# of @nodes# hidden)})
|
|
(newline)
|
|
(display-table
|
|
'(r l r l l r l l l r l l)
|
|
(append*
|
|
`(,=sep
|
|
(" " " " " "" " " " " "" " " " " Caller")
|
|
("Idx" " " "To""tal " " " "Se""lf " " " "Name+src" "Local%")
|
|
(" " " " " ms""(pct)" " " "ms""(pct)" " " " Callee")
|
|
,=sep)
|
|
(for/list ([node (in-list nodes)])
|
|
(define index (node-> 'index node))
|
|
(define name (node-> 'label node))
|
|
(define total (node-total node))
|
|
(define totalS (f:msec total))
|
|
(define total% @string-append{(@(format-percent total total-time))})
|
|
(define self (node-self node))
|
|
(define selfS (f:msec self))
|
|
(define self% @string-append{(@(format-percent self total-time))})
|
|
(define name+src
|
|
(let* ([src (format-source (node-src node))]
|
|
[src-len (string-length src)]
|
|
[name-len (string-length name)])
|
|
(string-append
|
|
name " "
|
|
;; truncate-source only truncates the source
|
|
(let* ([n (and truncate-source
|
|
((+ src-len name-len 1) . - . truncate-source))]
|
|
[n (and n (positive? n) (- src-len n 3))])
|
|
(cond [(not n) src]
|
|
[(n . <= . 0) "..."]
|
|
[else (string-append "..."
|
|
(substring src (- src-len n)))])))))
|
|
(define (sub get-edges get-node get-node-time)
|
|
(for*/list ([edge (in-list (get-edges node))]
|
|
[sub (in-list (list (get-node edge)))] ; <-- hack...
|
|
#:unless (or (eq? *-node sub) ; <-- ...for this
|
|
(memq sub hidden)))
|
|
(define name (node-> 'sub-label sub))
|
|
(define local% (format-percent (get-node-time edge) total))
|
|
`("" "" "" "" "" "" "" ""
|
|
,(string-append " " name) ,local%
|
|
"" "")))
|
|
`(,@(reverse (sub node-callers edge-caller edge-caller-time))
|
|
(,(node-> 'index node)
|
|
" " ,totalS ,total%
|
|
" " ,selfS ,self%
|
|
" " ,(λ () name+src))
|
|
,@(sub node-callees edge-callee edge-callee-time)
|
|
,-sep)))))
|