/usr/share/racket/pkgs/profile-lib/sampler.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 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 | #lang racket/base
;; The core profiler sample collector
;; (This module is a private tool for collecting profiling data, and should not
;; be used as is.)
(provide create-sampler)
(require errortrace/errortrace-key)
;; (cons sexp srcloc) -> (cons sexp srcloc)
;; abbreviate the expression for concise reports
;; we take the first symbol we can find, and wrap it in a stub expression
(define (errortrace-preprocess frame)
(cons (and (car frame)
(let loop ([e (car frame)])
(cond [(symbol? e) (list e '...)]
[(pair? e) (loop (car e))]
[else (error 'errortrace-preprocess
"unexpected frame: ~a" frame)])))
(and (cdr frame)
(apply srcloc (cdr frame)))))
;; create-sampler : creates a sample collector thread, which tracks the given
;; `to-track' value every `delay' seconds.
;; Uses errortrace annotations when #:use-errortrace? is specified, otherwise
;; uses the native stack traces provided by `cms->context`.
;; * The input value can be either a thread (track just that thread), a
;; custodian (track all threads managed by the custodian), or a list of
;; threads and/or custodians. If a custodian is given, it must be
;; subordinate to the current custodian or to the given super custodian.
;; Also optionally takes a list of continuation mark keys, which will be
;; monitored in addition to the stack trace continuation mark key.
;; * The collected values are (<thread-id> <thread-time> . <stack>), where
;; - The <thread-id> is an integer number identifying the thread, starting
;; from 0. If the collected data has thread ids in a 0..N range
;; (exclusive) , then there were N threads that were observed. (This can
;; be relevant when tracking a custodian, where threads can change
;; dynamically.)
;; - The <thread-time> is the result of `current-process-milliseconds' for
;; the thread that this sample came from. Note that these numbers will not
;; start at 0, since threads are likely to run before a sample is
;; collected.
;; - Finally, the <stack> part is a snapshot of the thread's stack, as
;; grabbed by `continuation-mark-set->context'. The values in these
;; snapshots are interned to reduce memory load.
;; The results are collected sequentially, so they're always sorted from the
;; newest to the oldest. Remember that these results should be considered
;; private for the profiler collection, and can change when more information
;; needs to be collected.
;; * Returns a "controller" function that accepts messages to control the
;; sampler thread. The current set of messages that the controller
;; understands are:
;; - 'pause and 'resume: stops or resumes collecting samples. These messages
;; can be nested. Note that the thread will continue running it just won't
;; collect snapshots.
;; - 'stop: kills the collector thread. Should be called when you have your
;; data. (There is no message to start a new sampler thread, although
;; adding one will not be difficult.)
;; - 'set-tracked! <new>: changes the thread/s and/or custodian/s to track.
;; (Custodians should still be subordinate to the original one or to the
;; given argument.)
;; - 'set-delay! <new>: changes the sampling delay. This means that we won't
;; have a direct correlation between the number of samples and the time
;; they represent -- but the samples are statistical snapshots anyway, and
;; the results are not formulated in terms of time spent. (The time spent
;; could be added of course, but it is best to do that in terms of the
;; start/stop times)
;; - 'get-snapshots: returns the currently collected list of snapshots. Note
;; that this can be called multiple times, each will return the data that
;; is collected up to that point in time.
;; - 'get-custom-snapshots: returns the currently collected list of custom
;; key snapshots. Returns a list of samples, where each sample is in the
;; same format as the output of continuation-mark-set->list*.
(define (create-sampler to-track delay
[super-cust (current-custodian)]
[custom-keys #f]
#:use-errortrace? [do-errortrace #f])
;; the collected data
(define snapshots '())
;; listof (cons continuation-mark-key value/#f)
(define custom-snapshots '())
;; intern the entries (which are (cons id/#f srcloc/#f))
(define entry-table (make-hash))
(define (intern-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)
(unless (or (not custom-keys) (list? custom-keys))
(raise-type-error
who "list of continuation mark keys" custom-keys))
(let loop ([t to-track])
(cond
[(thread? t)]
[(list? t) (for-each loop t)]
[(not (custodian? t))
(raise-type-error
who "thread, custodian, or a list of threads/custodians" to-track)]
;; test that it's subordinate
[(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)])
(λ (thd)
(or (hash-ref t thd #f)
(let ([id next-id])
(set! next-id (add1 next-id))
(hash-set! t thd id)
id)))))
(define (sampler)
(sleep delay)
(when (paused . <= . 0)
(let loop ([t to-track])
(cond [(thread? t)
(unless (eq? t sampler-thread)
(when custom-keys
(set! custom-snapshots
(cons (continuation-mark-set->list*
(continuation-marks t)
custom-keys) ; frames
custom-snapshots)))
(set! snapshots
(cons (list* (thread-id t)
(current-process-milliseconds t)
(if do-errortrace
(for/list ([frame (in-list
(continuation-mark-set->list
(continuation-marks t)
errortrace-key))])
(intern-entry (errortrace-preprocess frame)))
(map intern-entry
(continuation-mark-set->context
(continuation-marks t)))))
snapshots)))]
[(custodian? t)
(for-each loop (custodian-managed-list t super-cust))]
;; cannot assume that it's a list: we might get other values from
;; a custodian managed list
[(list? t) (for-each loop t)])))
(sampler))
(define cpu-time 0)
(define start-time (current-process-milliseconds))
(define (add-time)
(when (paused . <= . 0)
(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))))
(define sampler-thread
(begin (validate to-track 'create-sampler)
(thread sampler)))
;; use a sema to avoid mutations from different threads, the sampler thread
;; is only reading these values so it doesn't use it.
(define sema (make-semaphore 1))
(define (sampler-controller msg [arg #f])
(define-syntax-rule (w/sema 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))]
[(stop) (kill-thread sampler-thread) (add-time) (set! paused +inf.0)]
[(set-tracked!) (validate arg 'sampler-controller)
(w/sema (set! to-track arg))]
[(set-delay!) (w/sema (set! delay arg))]
[(get-snapshots) (add-time) (cons cpu-time snapshots)]
[(get-custom-snapshots) custom-snapshots]
[else (error 'sampler-controller "unknown message: ~e" msg)]))
sampler-controller)
|