diff --git a/collects/profile/analyzer.rkt b/collects/profile/analyzer.rkt index 82ad451..34e8474 100644 --- a/collects/profile/analyzer.rkt +++ b/collects/profile/analyzer.rkt @@ -6,8 +6,8 @@ (provide analyze-samples (all-from-out "structs.rkt")) -(define-syntax-rule (with-hash ) - (hash-ref! (lambda () ))) +(define-syntax-rule (with-hash ...) + (hash-ref! (λ () ...))) ;; This function analyzes the output of the sampler. Returns a `profile' ;; struct holding a list of `node' values, each one representing a node in the @@ -25,17 +25,17 @@ (define id+src->node-hash (make-hasheq)) (define (id+src->node id+src) (with-hash id+src->node-hash id+src - (node (car id+src) (cdr id+src) '() 0 0 '() '()))) + (node (car id+src) (cdr id+src) '() 0 0 '() '()))) ;; special node that is the caller of toplevels and callee of leaves (define *-node (id+src->node '(#f . #f))) (define call->edge (let ([t (make-hasheq)]) - (lambda (ler lee) + (λ (ler lee) (with-hash (with-hash t ler (make-hasheq)) lee - (let ([e (edge 0 ler 0 lee 0)]) - (set-node-callers! lee (cons e (node-callers lee))) - (set-node-callees! ler (cons e (node-callees ler))) - e))))) + (define e (edge 0 ler 0 lee 0)) + (set-node-callers! lee (cons e (node-callers lee))) + (set-node-callees! ler (cons e (node-callees ler))) + e)))) (define total-time 0) (define thread-times (make-vector (vector-length samples-by-thread) 0)) (for ([thread-samples (in-vector samples-by-thread)] @@ -50,12 +50,13 @@ edge) (define stack ; the stack snapshot, translated to `node' values (for/list ([id+src (in-list (cdr sample))]) - (let* ([node (id+src->node id+src)] [tids (node-thread-ids node)]) - (unless (memq thread-id tids) - (set-node-thread-ids! node (cons thread-id tids))) - node))) + (define node (id+src->node id+src)) + (define tids (node-thread-ids node)) + (unless (memq thread-id tids) + (set-node-thread-ids! node (cons thread-id tids))) + node)) (define counts (get-counts stack)) - (define stack+counts (map (lambda (x) (assq x counts)) stack)) + (define stack+counts (map (λ (x) (assq x counts)) stack)) (define edges (if (null? stack) '() @@ -78,19 +79,19 @@ (set-node-total! *-node total-time) ;; convert the nodes from the hash to a list, do a topological sort, and then ;; sort by total time (combining both guarantees(?) sensible order) - (let ([nodes (append-map (lambda (nodes) (sort nodes > #:key node-total)) - (topological-sort *-node))]) - ;; sort all the edges in the nodes according to total time - (for ([n (in-list nodes)]) - (set-node-callees! n (sort (node-callees n) > #:key edge-callee-time)) - (set-node-callers! n (sort (node-callers n) > #:key edge-caller-time))) - (profile total-time - cpu-time - (length samples) - (for/list ([time (in-vector thread-times)] [n (in-naturals 0)]) - (cons n time)) - nodes - *-node))) + (define nodes (append-map (λ (nodes) (sort nodes > #:key node-total)) + (topological-sort *-node))) + ;; sort all the edges in the nodes according to total time + (for ([n (in-list nodes)]) + (set-node-callees! n (sort (node-callees n) > #:key edge-callee-time)) + (set-node-callers! n (sort (node-callers n) > #:key edge-caller-time))) + (profile total-time + cpu-time + (length samples) + (for/list ([time (in-vector thread-times)] [n (in-naturals 0)]) + (cons n time)) + nodes + *-node)) ;; Groups raw samples by their thread-id, returns a vector with a field for ;; each thread id holding the sample data for that thread. The samples in @@ -101,8 +102,9 @@ (max (car sample) n))) '())) (for ([sample (in-list samples)]) - (let ([id (car sample)] [data (cdr sample)]) - (vector-set! threads id (cons data (vector-ref threads id))))) + (define id (car sample)) + (define data (cdr sample)) + (vector-set! threads id (cons data (vector-ref threads id)))) threads) #| (equal? (split-by-thread '()) diff --git a/collects/profile/main.rkt b/collects/profile/main.rkt index 6a25827..3a14dbe 100644 --- a/collects/profile/main.rkt +++ b/collects/profile/main.rkt @@ -21,17 +21,16 @@ (and periodic-renderer (let ([delay (car periodic-renderer)] [renderer (cadr periodic-renderer)]) - (thread (lambda () - (let loop () - (sleep delay) - (renderer (analyze-samples (sampler 'get-snapshots))) - (loop))))))) + (define (loop) + (sleep delay) + (renderer (analyze-samples (sampler 'get-snapshots))) + (loop)) + (thread loop)))) (define (run) (for ([i (in-range rpt)]) (thunk))) - (with-handlers ([void (lambda (e) - (eprintf "profiled thunk error: ~a\n" - (if (exn? e) - (exn-message e) - (format "~e" e))))]) + (with-handlers ([void (λ (e) (eprintf "profiled thunk error: ~a\n" + (if (exn? e) + (exn-message e) + (format "~e" e))))]) (if threads? (parameterize ([current-custodian cust]) (run)) (run))) @@ -47,7 +46,7 @@ [(null? xs) (if expr (with-syntax ([expr expr] [kwds (reverse kwds)]) - #'(profile-thunk (lambda () expr) . kwds)) + #'(profile-thunk (λ () expr) . kwds)) (raise-syntax-error 'profile "missing expression" stx))] [(keyword? (syntax-e (car xs))) (if (pair? (cdr xs)) diff --git a/collects/profile/render-graphviz.rkt b/collects/profile/render-graphviz.rkt index 0c23a53..1b047c6 100644 --- a/collects/profile/render-graphviz.rkt +++ b/collects/profile/render-graphviz.rkt @@ -14,15 +14,16 @@ (define node-> (let ([t (make-hasheq)]) (for ([node (in-list nodes)] [idx (in-naturals 1)]) - (let ([id (node-id node)] [src (node-src node)]) + (define id (node-id node)) + (define src (node-src node)) (hash-set! t node (list (format "node~a" idx) (if id (format "~a" id) (regexp-replace #rx"^.*/" (format-source (node-src node)) - "")))))) - (lambda (mode node) + ""))))) + (λ (mode node) ((case mode [(index) car] [(label) cadr]) (hash-ref t node))))) (define max-self% (/ (for/fold ([m 0]) ([node (in-list nodes)]) (max m (node-self node))) diff --git a/collects/profile/render-text.rkt b/collects/profile/render-text.rkt index a341ed2..abbc6af 100644 --- a/collects/profile/render-text.rkt +++ b/collects/profile/render-text.rkt @@ -2,7 +2,7 @@ (provide render) -(require "analyzer.rkt" "utils.rkt" racket/list) +(require "analyzer.rkt" "utils.rkt" racket/list racket/string) (define (f:msec msec) (number->string (round (inexact->exact msec)))) @@ -14,30 +14,31 @@ ;; * 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" +$" (apply string-append strings) ""))) - (let ([widths (let loop ([table table]) - (let ([table (filter pair? table)]) - (if (null? table) '() - (cons (apply max (filter-map - (lambda (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)]) - (let* ([cell (cond [(char? cell) (make-string width cell)] - [(procedure? cell) (cell)] - [else cell])] - [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")]))))))) + (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 #:truncate-source [truncate-source 50] @@ -61,10 +62,10 @@ (define node-> (let ([t (make-hasheq)]) (for ([node (in-list nodes)] [idx (in-naturals 1)]) - (let ([index (format "[~a]" idx)] - [label (format "~a" (or (node-id node) '???))]) - (hash-set! t node (list index label @string-append{@label @index})))) - (lambda (mode node) + (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)) @@ -79,14 +80,14 @@ (when (> (length threads+times) 1) @show{ Threads observed: @(length threads+times)}) (when (pair? hidden) - (let* ([hidden (length hidden)] - [nodes (length (profile-nodes profile))] - [self% @string-append{self<@(format-percent (or hide-self% 0))}] - [subs% @string-append{local<@(format-percent (or hide-subs% 0))}] - [%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)})) + (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) @@ -133,6 +134,6 @@ (,(node-> 'index node) " " ,totalS ,total% " " ,selfS ,self% - " " ,(lambda () name+src)) + " " ,(λ () name+src)) ,@(sub node-callees edge-callee edge-callee-time) ,-sep))))) diff --git a/collects/profile/sampler.rkt b/collects/profile/sampler.rkt index 9dadc6b..dbc7d02 100644 --- a/collects/profile/sampler.rkt +++ b/collects/profile/sampler.rkt @@ -56,15 +56,15 @@ ;; intern the entries (which are (cons id/#f srcloc/#f)) (define entry-table (make-hash)) (define (intern-entry entry) - (let* ([key (or (cdr entry) (car entry))] - [en (hash-ref entry-table key #f)]) - (if en - ;; ELI: is this sanity check needed? - ;; (if (equal? en entry) - ;; en - ;; (error 'profile "internal error: assumption invalid")) - en - (begin (hash-set! entry-table key entry) entry)))) + (define key (or (cdr entry) (car entry))) + (define en (hash-ref entry-table key #f)) + (if en + ;; ELI: is this sanity check needed? + ;; (if (equal? en entry) + ;; en + ;; (error 'profile "internal error: assumption invalid")) + en + (begin (hash-set! entry-table key entry) entry))) (define (validate to-track who) (let loop ([t to-track]) (cond @@ -74,13 +74,13 @@ (raise-type-error who "thread, custodian, or a list of threads/csutodians" to-track)] ;; test that it's subordinate - [(with-handlers ([exn:fail:contract? (lambda (_) #t)]) + [(with-handlers ([exn:fail:contract? (λ (_) #t)]) (custodian-managed-list t super-cust) #f) (error who "got an insubordinate custodian")]))) (define paused 0) (define thread-id (let ([next-id 0] [t (make-weak-hasheq)]) - (lambda (thd) + (λ (thd) (or (hash-ref t thd #f) (let ([id next-id]) (set! next-id (add1 next-id)) @@ -109,9 +109,9 @@ (define start-time (current-process-milliseconds)) (define (add-time) (when (paused . <= . 0) - (let ([cur (current-process-milliseconds)]) - (set! cpu-time (+ cpu-time (- cur start-time))) - (set! start-time cur)))) + (define cur (current-process-milliseconds)) + (set! cpu-time (+ cpu-time (- cur start-time))) + (set! start-time cur))) (define (ignore-time) (when (paused . <= . 0) (set! start-time (current-process-milliseconds)))) @@ -123,7 +123,7 @@ (define sema (make-semaphore 1)) (define (sampler-controller msg [arg #f]) (define-syntax-rule (w/sema body ...) - (call-with-semaphore sema (lambda () body ...))) + (call-with-semaphore sema (λ () body ...))) (case msg [(pause) (w/sema (add-time) (set! paused (add1 paused)))] [(resume) (w/sema (set! paused (sub1 paused)) (ignore-time))] diff --git a/collects/profile/scribblings/renderers.scrbl b/collects/profile/scribblings/renderers.scrbl index 641b64b..5f188e5 100644 --- a/collects/profile/scribblings/renderers.scrbl +++ b/collects/profile/scribblings/renderers.scrbl @@ -29,26 +29,27 @@ function that consumes a @racket[profile] instance. See the Prints the given @racket[profile] results as a textual table. -The printout begins with some general details about the profile, and -then a table that represents the call-graph is printed. Each row in -this table looks like: +The printout begins with general information about the profile, +followed by a table with an entry for each function in the call graph. +The entries are displayed in a topological order (roughly, since the +graph can have cycles). This means that it is usually easy to find +the callers and callees of a function in its close environment. +Each row in the table has the following format: @verbatim[#:indent 2]{ B [M1] M2% [N1] N2(N3%) N4(N5%) A ...path/to/source.rkt:12:34 C [M3] M4%} - -where actual numbers appear in the printout. The meaning of the -numbers and labels is as follows: +with the following meaning of the numbers and labels: @itemize[ @item{@tt{A} --- the name of the function that this node represents, followed by the source location for the function if it is known. - The name can be ``???'' for anonymous functions, but in this case - the source location will identify them.} -@item{@tt{N1} --- an index number associated with this node. This is - useful in references to this function, since the symbolic names are - not unique (and some can be missing). The number itself has no - significance.} + The name can be ``???'' for anonymous functions, which will be + identified with their source location.} +@item{@tt{N1} --- an integer label associated with this node in the + printout. This label is used to mark references to this function, + since symbolic names are not unique (and they can be missing or very + long). The labels are assigned from the top.} @item{@tt{N2} --- the time (in milliseconds) that this function has been anywhere in a stack snapshot. This is the total time that the execution was somewhere in this function or in its callees. diff --git a/collects/profile/scribblings/toplevel.scrbl b/collects/profile/scribblings/toplevel.scrbl index be663a7..ec42196 100644 --- a/collects/profile/scribblings/toplevel.scrbl +++ b/collects/profile/scribblings/toplevel.scrbl @@ -59,9 +59,11 @@ can customize the profiling: accumulated data is analyzed (by @racket[analyze-samples]) and the resulting profile value is sent to the @racket[renderer] function. See @secref["renderers"] for available renderers. You can also use - @racket[values] as a ``renderer''---in this case the + @racket[values] as a ``renderer''---in this case @racket[profile-thunk] returns the analyzed information which can - now be rendered multiple times, or saved for future rendering.} + now be rendered multiple times, or saved for rendering directly + using one of the renderers, perhaps multiple times for different + views.} @item{To provide feedback information during execution, specify a @racket[periodic-renderer]. This should be a list holding a delay diff --git a/collects/profile/structs.rkt b/collects/profile/structs.rkt index 1f6a513..0d0c931 100644 --- a/collects/profile/structs.rkt +++ b/collects/profile/structs.rkt @@ -34,7 +34,7 @@ (define-struct node (id src thread-ids total self callers callees) #:mutable #:property prop:custom-write - (lambda (node o w?) + (λ (node o w?) (fprintf o "#" (or (node-id node) (if (node-src node) '??? 'ROOT))))) @@ -49,7 +49,7 @@ (define-struct edge (total caller caller-time callee callee-time) #:mutable #:property prop:custom-write - (lambda (edge o w?) + (λ (edge o w?) (fprintf o "#" (or (node-id (edge-caller edge)) '???) (or (node-id (edge-callee edge)) '???)))) diff --git a/collects/profile/utils.rkt b/collects/profile/utils.rkt index 8b9430e..cef1ba0 100644 --- a/collects/profile/utils.rkt +++ b/collects/profile/utils.rkt @@ -10,9 +10,8 @@ (provide format-percent) (define format-percent (case-lambda - [(percent) - (let ([percent (inexact->exact (round (* percent 1000)))]) - (format "~a.~a%" (quotient percent 10) (modulo percent 10)))] + [(percent) (define p (inexact->exact (round (* percent 1000)))) + (format "~a.~a%" (quotient p 10) (modulo p 10))] [(x y) (format-percent (if (zero? y) 0 (/ x y)))])) (provide format-source) @@ -36,9 +35,9 @@ (define (hide? node) (define (hide-sub? get-subs edge-sub edge-sub-time) (define %s - (map (lambda (edge) - (let ([total (node-total (edge-sub edge))]) - (if (zero? total) 0 (/ (edge-sub-time edge) total)))) + (map (λ (edge) + (define total (node-total (edge-sub edge))) + (if (zero? total) 0 (/ (edge-sub-time edge) total))) (get-subs node))) (subs% . >= . (apply max %s))) (and (self% . >= . (/ (node-self node) total-time)) @@ -54,8 +53,8 @@ ;; item in the first level, so it is not included in the result. This is done ;; by assigning layers to nodes in a similar way to section 9.1 of "Graph ;; Drawing: Algorithms for the Visualization of Graphs" by Tollis, Di Battista, -;; Eades, and Tamassia. It uses a similar technique to the one described in -;; section 9.4 to remove cycles in the input graph, but improved by the fact +;; Eades, and Tamassia. It uses a technique similar to the one described in +;; section 9.4 for removing cycles in the input graph, but improved by the fact ;; that we have weights on input/output edges (this is the only point that is ;; specific to the fact that it's a profiler graph). Note that this is useful ;; for a graphical rendering of the results, but it's also useful to sort the @@ -69,9 +68,9 @@ (define (get-node+io node) (define (sum node-callers/lees edge-caller/lee edge-callee/ler-time) (for/fold ([sum 0]) ([e (in-list (node-callers/lees node))]) - (let ([n (edge-caller/lee e)]) - (if (or (eq? n node) (eq? n root)) sum - (+ sum (edge-callee/ler-time e)))))) + (define n (edge-caller/lee e)) + (if (or (eq? n node) (eq? n root)) sum + (+ sum (edge-callee/ler-time e))))) (cons node (mcons (sum node-callers edge-caller edge-callee-time) (sum node-callees edge-callee edge-caller-time)))) (define nodes+io-times @@ -80,11 +79,11 @@ (let* ([cur (car todo)] [todo (cdr todo)] [r (if (eq? cur root) r (cons (get-node+io cur) r))]) (loop (append todo ; append new things in the end, so it's a BFS - (filter-map (lambda (e) - (let ([lee (edge-callee e)]) - (and (not (memq lee todo)) - (not (assq lee r)) - lee))) + (filter-map (λ (e) + (define lee (edge-callee e)) + (and (not (memq lee todo)) + (not (assq lee r)) + lee)) (node-callees cur))) r)) ;; note: the result does not include the root node @@ -108,9 +107,9 @@ (loop rest (list 1st) ratio) (loop rest (if (ratio . > . best) r (cons 1st r)) best)))))) (if (pair? todo) - (let* ([sinks (filter (lambda (x) (zero? (mcdr (cdr x)))) todo)] + (let* ([sinks (filter (λ (x) (zero? (mcdr (cdr x)))) todo)] [todo (remq* sinks todo)] - [sources (filter (lambda (x) (zero? (mcar (cdr x)))) todo)] + [sources (filter (λ (x) (zero? (mcar (cdr x)))) todo)] ;; if we have no sources and sinks, use the heuristic [sources (if (and (null? sinks) (null? sources)) (best-sources) sources)] @@ -121,13 +120,13 @@ (for* ([nodes (in-list (list sources sinks))] [n (in-list nodes)]) (for ([e (in-list (node-callees n))]) - (let ([x (assq (edge-callee e) todo)]) - (when x (set-mcar! (cdr x) (- (mcar (cdr x)) - (edge-callee-time e)))))) + (define x (assq (edge-callee e) todo)) + (when x + (set-mcar! (cdr x) (- (mcar (cdr x)) (edge-callee-time e))))) (for ([e (in-list (node-callers n))]) - (let ([x (assq (edge-caller e) todo)]) - (when x (set-mcdr! (cdr x) (- (mcdr (cdr x)) - (edge-caller-time e))))))) + (define x (assq (edge-caller e) todo)) + (when x + (set-mcdr! (cdr x) (- (mcdr (cdr x)) (edge-caller-time e)))))) (loop todo (append (reverse sources) rev-left) (append sinks right))) ;; all done, get the order (append (reverse rev-left) right)))) @@ -138,36 +137,37 @@ (let ([t (make-hasheq)]) (let loop ([nodes acyclic-order]) (when (pair? nodes) - (let ([ler (car nodes)] [rest (cdr nodes)]) - (unless (hash-ref t ler #f) (hash-set! t ler '())) - (for ([e (in-list (node-callees ler))]) - (let ([lee (edge-callee e)]) - (when (memq lee rest) ; only consistent edges - ;; note that we connect each pair of nodes at most once, and - ;; never a node with itself - (hash-set! t lee (cons ler (hash-ref t lee '())))))) - (loop rest)))) + (define ler (car nodes)) + (define rest (cdr nodes)) + (unless (hash-ref t ler #f) (hash-set! t ler '())) + (for ([e (in-list (node-callees ler))]) + (define lee (edge-callee e)) + (when (memq lee rest) ; only consistent edges + ;; note that we connect each pair of nodes at most once, and + ;; never a node with itself + (hash-set! t lee (cons ler (hash-ref t lee '()))))) + (loop rest))) t)) ;; finally, assign layers using the simple method from section 9.1: sources ;; are at 0, and other nodes are placed at one layer after their parents - (let ([height 0]) - (for ([node (in-list acyclic-order)]) - (let loop ([node node]) - (define x (hash-ref t node)) - (if (number? x) - x - (let ([max (add1 (for/fold ([m -1]) ([ler (in-list x)]) - (max m (loop ler))))]) - (when (max . > . height) (set! height max)) - (hash-set! t node max) - max)))) - (let ([layers (make-vector (add1 height) '())]) - (for ([node (in-list acyclic-order)]) - (unless (eq? node root) ; filter out the root - (let ([l (hash-ref t node)]) - (vector-set! layers l (cons node (vector-ref layers l)))))) - ;; in almost all cases, the root is the full first layer (in a few cases - ;; it can be there with another node, eg (* -> A 2-> B 3-> A)), but be - ;; safe and look for any empty layer - (filter pair? (vector->list layers))))) + (define height 0) + (for ([node (in-list acyclic-order)]) + (let loop ([node node]) + (define x (hash-ref t node)) + (if (number? x) + x + (let ([max (add1 (for/fold ([m -1]) ([ler (in-list x)]) + (max m (loop ler))))]) + (when (max . > . height) (set! height max)) + (hash-set! t node max) + max)))) + (define layers (make-vector (add1 height) '())) + (for ([node (in-list acyclic-order)]) + (unless (eq? node root) ; filter out the root + (define l (hash-ref t node)) + (vector-set! layers l (cons node (vector-ref layers l))))) + ;; in almost all cases, the root is the full first layer (in a few cases it + ;; can be there with another node, eg (* -> A 2-> B 3-> A)), but be safe and + ;; look for any empty layer + (filter pair? (vector->list layers)))