Doc and code style improvements in the profiler.

original commit: 826a5f360f6690ba7d6c7ffe268e8dca145220b3

collects/profile/analyzer.rkt

@@ -6,8 +6,8 @@
 
 (provide analyze-samples (all-from-out "structs.rkt"))
 
-(define-syntax-rule (with-hash <hash> <key> <expr>)
+(define-syntax-rule (with-hash <hash> <key> <expr> ...)
-  (hash-ref! <hash> <key> (lambda () <expr>)))
+  (hash-ref! <hash> <key> (λ () <expr> ...)))
 
 ;; 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
@@ -30,12 +30,12 @@
   (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)])
+          (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)))))
+          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)])
+        (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)))
+        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,8 +79,8 @@
   (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))
+  (define nodes (append-map (λ (nodes) (sort nodes > #:key node-total))
-                           (topological-sort *-node))])
+                            (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))
@@ -90,7 +91,7 @@
            (for/list ([time (in-vector thread-times)] [n (in-naturals 0)])
              (cons n time))
            nodes
-             *-node)))
+           *-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)])
+    (define id (car sample))
-      (vector-set! threads id (cons data (vector-ref threads id)))))
+    (define data (cdr sample))
+    (vector-set! threads id (cons data (vector-ref threads id))))
   threads)
 #|
 (equal? (split-by-thread '())

collects/profile/main.rkt

@@ -21,14 +21,13 @@
     (and periodic-renderer
          (let ([delay (car periodic-renderer)]
                [renderer (cadr periodic-renderer)])
-           (thread (lambda ()
+           (define (loop)
-                     (let loop ()
              (sleep delay)
              (renderer (analyze-samples (sampler 'get-snapshots)))
-                       (loop)))))))
+             (loop))
+           (thread loop))))
   (define (run) (for ([i (in-range rpt)]) (thunk)))
-  (with-handlers ([void (lambda (e)
+  (with-handlers ([void (λ (e) (eprintf "profiled thunk error: ~a\n"
-                          (eprintf "profiled thunk error: ~a\n"
                                         (if (exn? e)
                                           (exn-message e)
                                           (format "~e" e))))])
@@ -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))

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

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) "")))
+    (printf "~a\n" (regexp-replace #rx" +$" (string-append* strings) "")))
-  (let ([widths (let loop ([table table])
+  (define widths
-                  (let ([table (filter pair? table)])
+    (let loop ([table table])
-                    (if (null? table) '()
+      (define table* (filter pair? table))
-                        (cons (apply max (filter-map
+      (if (null? table*) '()
-                                          (lambda (x)
+          (cons (apply max
-                                            (and (string? (car x))
+                       (filter-map
-                                                 (string-length (car x))))
+                        (λ (x) (and (string? (car x)) (string-length (car x))))
-                                          table))
+                        table*))
-                              (loop (map cdr 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)]
+       (define cell*
+         (cond [(char? cell) (make-string width cell)]
                [(procedure? cell) (cell)]
-                            [else cell])]
+               [else cell]))
-                [pad  (make-string (max 0 (- width (string-length cell)))
+       (define pad
-                                   #\space)])
+         (make-string (max 0 (- width (string-length cell*))) #\space))
        (case align
-             [(l) (string-append cell pad)]
+         [(l) (string-append cell* pad)]
-             [(r) (string-append pad cell)]
+         [(r) (string-append pad cell*)]
-             [else (error 'internal-error "poof")])))))))
+         [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)]
+        (define index (format "[~a]" idx))
-              [label (format "~a" (or (node-id node) '???))])
+        (define label (format "~a" (or (node-id node) '???)))
-          (hash-set! t node (list index label @string-append{@label @index}))))
+        (hash-set! t node (list index label @string-append{@label @index})))
-      (lambda (mode node)
+      (λ (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)]
+    (define hidden# (length hidden))
-           [nodes (length (profile-nodes profile))]
+    (define nodes#  (length (profile-nodes profile)))
-           [self% @string-append{self<@(format-percent (or hide-self% 0))}]
+    (define self%   @string-append{self<@(format-percent (or hide-self% 0))})
-           [subs% @string-append{local<@(format-percent (or hide-subs% 0))}]
+    (define subs%   @string-append{local<@(format-percent (or hide-subs% 0))})
-           [%s (cond [(not hide-self%) subs%]
+    (define %s      (cond [(not hide-self%) subs%]
                           [(not hide-subs%) self%]
-                     [else @string-append{@self% and @subs%}])])
+                          [else @string-append{@self% and @subs%}]))
-      @show{  (Hiding functions with @|%s|: @|hidden| of @nodes hidden)}))
+    @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)))))

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))]
+    (define key (or (cdr entry) (car entry)))
-           [en  (hash-ref entry-table key #f)])
+    (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))))
+      (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)])
+      (define cur (current-process-milliseconds))
       (set! cpu-time (+ cpu-time (- cur start-time)))
-        (set! start-time cur))))
+      (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))]

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
+The printout begins with general information about the profile,
-then a table that represents the call-graph is printed.  Each row in
+followed by a table with an entry for each function in the call graph.
-this table looks like:
+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%}
-
+with the following meaning of the numbers and labels:
-where actual numbers appear in the printout.  The meaning of the
-numbers and labels is as follows:
 @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 name can be ``???'' for anonymous functions, which will be
-  the source location will identify them.}
+  identified with their source location.}
-@item{@tt{N1} --- an index number associated with this node.  This is
+@item{@tt{N1} --- an integer label associated with this node in the
-  useful in references to this function, since the symbolic names are
+  printout.  This label is used to mark references to this function,
-  not unique (and some can be missing).  The number itself has no
+  since symbolic names are not unique (and they can be missing or very
-  significance.}
+  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.

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

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 "#<node:~s>"
              (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 "#<edge:~s-~s>"
              (or (node-id (edge-caller edge)) '???)
              (or (node-id (edge-callee edge)) '???))))

collects/profile/utils.rkt

@@ -10,9 +10,8 @@
 (provide format-percent)
 (define format-percent
   (case-lambda
-    [(percent)
+    [(percent) (define p (inexact->exact (round (* percent 1000))))
-     (let ([percent (inexact->exact (round (* percent 1000)))])
+               (format "~a.~a%" (quotient p 10) (modulo p 10))]
-       (format "~a.~a%" (quotient percent 10) (modulo percent 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)
+        (map (λ (edge)
-               (let ([total (node-total (edge-sub edge))])
+               (define total (node-total (edge-sub edge)))
-                 (if (zero? total) 0 (/ (edge-sub-time edge) total))))
+               (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
+;; Eades, and Tamassia.  It uses a technique similar to the one described in
-;; section 9.4 to remove cycles in the input graph, but improved by the fact
+;; 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)])
+        (define n (edge-caller/lee e))
         (if (or (eq? n node) (eq? n root)) sum
-              (+ sum (edge-callee/ler-time e))))))
+            (+ 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)
+                        (filter-map (λ (e)
-                                      (let ([lee (edge-callee e)])
+                                      (define lee (edge-callee e))
                                       (and (not (memq lee todo))
                                            (not (assq lee r))
-                                             lee)))
+                                           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)])
+              (define x (assq (edge-callee e) todo))
-                (when x (set-mcar! (cdr x) (- (mcar (cdr x))
+              (when x
-                                              (edge-callee-time e))))))
+                (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)])
+              (define x (assq (edge-caller e) todo))
-                (when x (set-mcdr! (cdr x) (- (mcdr (cdr x))
+              (when x
-                                              (edge-caller-time e)))))))
+                (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,20 +137,21 @@
     (let ([t (make-hasheq)])
       (let loop ([nodes acyclic-order])
         (when (pair? nodes)
-          (let ([ler (car nodes)] [rest (cdr nodes)])
+          (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))])
-              (let ([lee (edge-callee e)])
+            (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 '()))))))
+              (hash-set! t lee (cons ler (hash-ref t lee '())))))
-            (loop rest))))
+          (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])
+  (define height 0)
   (for ([node (in-list acyclic-order)])
     (let loop ([node node])
       (define x (hash-ref t node))
@@ -162,12 +162,12 @@
           (when (max . > . height) (set! height max))
           (hash-set! t node max)
           max))))
-    (let ([layers (make-vector (add1 height) '())])
+  (define 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)])
+      (define l (hash-ref t node))
-            (vector-set! layers l (cons node (vector-ref layers l))))))
+      (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
+  ;; in almost all cases, the root is the full first layer (in a few cases it
-      ;; it can be there with another node, eg (* -> A 2-> B 3-> A)), but be
+  ;; can be there with another node, eg (* -> A 2-> B 3-> A)), but be safe and
-      ;; safe and look for any empty layer
+  ;; look for any empty layer
-      (filter pair? (vector->list layers)))))
+  (filter pair? (vector->list layers)))