/usr/share/racket/pkgs/profile-lib/analyzer.rkt is in racket-common 6.7-3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 | #lang racket/base
;; Analyzer for the sampler results
(require "structs.rkt" "utils.rkt" racket/list)
(provide analyze-samples (all-from-out "structs.rkt"))
(define-syntax-rule (with-hash <hash> <key> <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
;; call graph, with the relevant information filled in. The results are sorted
;; using a topological sort from the top, and by the total time for nodes at
;; the same level.
(define (analyze-samples cpu-time+samples)
(define cpu-time (car cpu-time+samples))
(define samples (cdr cpu-time+samples))
(define samples-by-thread
(let ([by-thread (split-by-thread samples)])
(for ([samples (in-vector by-thread)] [i (in-naturals 0)])
(vector-set! by-thread i (get-times samples)))
by-thread))
(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 '() '())))
;; 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)])
(λ (ler lee)
(with-hash (with-hash t ler (make-hasheq)) lee
(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)]
[thread-id (in-naturals 0)]
#:when #t
[sample (in-list thread-samples)])
(define msecs (car sample))
(define (connect ler lee ler# lee#)
(define edge (call->edge ler lee))
(set-edge-caller-time! edge (+ (edge-caller-time edge) (/ msecs lee#)))
(set-edge-callee-time! edge (+ (edge-callee-time edge) (/ msecs ler#)))
edge)
(define stack ; the stack snapshot, translated to `node' values
(for/list ([id+src (in-list (cdr sample))])
(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 (λ (x) (assq x counts)) stack))
(define edges
(if (null? stack)
'()
(append (let ([first (car stack+counts)] [last (last stack+counts)])
(list (connect *-node (car last) 1 (cdr last))
(connect (car first) *-node (cdr first) 1)))
(for/list ([callee (in-list stack+counts)]
[caller (in-list (cdr stack+counts))])
(connect (car caller) (car callee)
(cdr caller) (cdr callee))))))
(set! total-time (+ msecs total-time))
(for ([p (in-list counts)])
(set-node-total! (car p) (+ msecs (node-total (car p)))))
(for ([e (remove-duplicates edges eq?)])
(set-edge-total! e (+ msecs (edge-total e))))
(vector-set! thread-times thread-id
(+ msecs (vector-ref thread-times thread-id)))
(when (pair? stack)
(set-node-self! (car stack) (+ (node-self (car stack)) msecs))))
(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)
(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
;; these are reversed (so they'll be sorted going forward in time).
(define (split-by-thread samples)
(define threads
(make-vector (add1 (for/fold ([n -1]) ([sample (in-list samples)])
(max (car sample) n)))
'()))
(for ([sample (in-list samples)])
(define id (car sample))
(define data (cdr sample))
(vector-set! threads id (cons data (vector-ref threads id))))
threads)
(module+ test
(require rackunit)
(check-equal? (split-by-thread '())
'#())
(check-equal? (split-by-thread '([0 x]))
'#([(x)]))
(check-equal? (split-by-thread '([0 x] [0 y] [0 z]))
'#([(z) (y) (x)]))
(check-equal? (split-by-thread '([0 x] [1 y] [2 z]))
'#([(x)] [(y)] [(z)]))
(check-equal? (split-by-thread '([0 x1] [1 y1] [0 x2] [2 z1] [0 x3] [2 z2]))
'#([(x3) (x2) (x1)] [(y1)] [(z2) (z1)])))
;; returns a list of (cons item occurrences) for the items in l
(define (get-counts l)
(let loop ([l l] [r '()])
(if (null? l)
r
(let ([1st (car l)])
(let loop* ([l1 '()] [c 1] [l (cdr l)])
(cond [(null? l) (loop l1 (cons (cons 1st c) r))]
[(eq? 1st (car l)) (loop* l1 (add1 c) (cdr l))]
[else (loop* (cons (car l) l1) c (cdr l))]))))))
(module+ test
(check-equal? (get-counts '()) '())
(check-equal? (get-counts '(1)) '([1 . 1]))
(check-equal? (get-counts '(1 1 1)) '([1 . 3]))
(define (set=? xs ys) (null? (append (remove* xs ys) (remove* ys xs))))
(check set=? (get-counts '(1 2 3)) '([1 . 1] [2 . 1] [3 . 1]))
(check set=? (get-counts '(1 2 2 3 3 3)) '([1 . 1] [2 . 2] [3 . 3]))
(check set=? (get-counts '(3 1 2 3 2 3)) '([1 . 1] [2 . 2] [3 . 3])))
|