Commit | Line | Data |
---|---|---|
47f3ce52 AW |
1 | ;;;; (statprof) -- a statistical profiler for Guile |
2 | ;;;; -*-scheme-*- | |
3 | ;;;; | |
998f8494 | 4 | ;;;; Copyright (C) 2009, 2010, 2011, 2013, 2014 Free Software Foundation, Inc. |
47f3ce52 AW |
5 | ;;;; Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com> |
6 | ;;;; Copyright (C) 2001 Rob Browning <rlb at defaultvalue dot org> | |
7 | ;;;; | |
8 | ;;;; This library is free software; you can redistribute it and/or | |
9 | ;;;; modify it under the terms of the GNU Lesser General Public | |
10 | ;;;; License as published by the Free Software Foundation; either | |
11 | ;;;; version 3 of the License, or (at your option) any later version. | |
12 | ;;;; | |
13 | ;;;; This library is distributed in the hope that it will be useful, | |
14 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
16 | ;;;; Lesser General Public License for more details. | |
17 | ;;;; | |
18 | ;;;; You should have received a copy of the GNU Lesser General Public | |
19 | ;;;; License along with this library; if not, write to the Free Software | |
20 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
21 | ;;;; | |
22 | \f | |
23 | ||
24 | ;;; Commentary: | |
998f8494 | 25 | ;;; |
62fd93e2 | 26 | ;;; @code{(statprof)} is a statistical profiler for Guile. |
998f8494 AW |
27 | ;;; |
28 | ;;; A simple use of statprof would look like this: | |
29 | ;;; | |
30 | ;;; @example | |
188e2ae3 AW |
31 | ;;; (statprof (lambda () (do-something)) |
32 | ;;; #:hz 100 | |
33 | ;;; #:count-calls? #t) | |
998f8494 AW |
34 | ;;; @end example |
35 | ;;; | |
188e2ae3 AW |
36 | ;;; This would run the thunk with statistical profiling, finally |
37 | ;;; displaying a gprof flat-style table of statistics which could | |
38 | ;;; something like this: | |
998f8494 AW |
39 | ;;; |
40 | ;;; @example | |
41 | ;;; % cumulative self self total | |
42 | ;;; time seconds seconds calls ms/call ms/call name | |
43 | ;;; 35.29 0.23 0.23 2002 0.11 0.11 - | |
44 | ;;; 23.53 0.15 0.15 2001 0.08 0.08 positive? | |
45 | ;;; 23.53 0.15 0.15 2000 0.08 0.08 + | |
46 | ;;; 11.76 0.23 0.08 2000 0.04 0.11 do-nothing | |
47 | ;;; 5.88 0.64 0.04 2001 0.02 0.32 loop | |
48 | ;;; 0.00 0.15 0.00 1 0.00 150.59 do-something | |
49 | ;;; ... | |
50 | ;;; @end example | |
51 | ;;; | |
52 | ;;; All of the numerical data with the exception of the calls column is | |
53 | ;;; statistically approximate. In the following column descriptions, and | |
54 | ;;; in all of statprof, "time" refers to execution time (both user and | |
55 | ;;; system), not wall clock time. | |
56 | ;;; | |
57 | ;;; @table @asis | |
58 | ;;; @item % time | |
59 | ;;; The percent of the time spent inside the procedure itself | |
60 | ;;; (not counting children). | |
61 | ;;; @item cumulative seconds | |
62 | ;;; The total number of seconds spent in the procedure, including | |
63 | ;;; children. | |
64 | ;;; @item self seconds | |
65 | ;;; The total number of seconds spent in the procedure itself (not counting | |
66 | ;;; children). | |
67 | ;;; @item calls | |
68 | ;;; The total number of times the procedure was called. | |
69 | ;;; @item self ms/call | |
70 | ;;; The average time taken by the procedure itself on each call, in ms. | |
71 | ;;; @item total ms/call | |
72 | ;;; The average time taken by each call to the procedure, including time | |
73 | ;;; spent in child functions. | |
74 | ;;; @item name | |
75 | ;;; The name of the procedure. | |
76 | ;;; @end table | |
77 | ;;; | |
78 | ;;; The profiler uses @code{eq?} and the procedure object itself to | |
79 | ;;; identify the procedures, so it won't confuse different procedures with | |
80 | ;;; the same name. They will show up as two different rows in the output. | |
81 | ;;; | |
82 | ;;; Right now the profiler is quite simplistic. I cannot provide | |
83 | ;;; call-graphs or other higher level information. What you see in the | |
84 | ;;; table is pretty much all there is. Patches are welcome :-) | |
85 | ;;; | |
86 | ;;; @section Implementation notes | |
87 | ;;; | |
88 | ;;; The profiler works by setting the unix profiling signal | |
89 | ;;; @code{ITIMER_PROF} to go off after the interval you define in the call | |
90 | ;;; to @code{statprof-reset}. When the signal fires, a sampling routine is | |
91 | ;;; run which looks at the current procedure that's executing, and then | |
92 | ;;; crawls up the stack, and for each procedure encountered, increments | |
93 | ;;; that procedure's sample count. Note that if a procedure is encountered | |
94 | ;;; multiple times on a given stack, it is only counted once. After the | |
95 | ;;; sampling is complete, the profiler resets profiling timer to fire | |
96 | ;;; again after the appropriate interval. | |
97 | ;;; | |
98 | ;;; Meanwhile, the profiler keeps track, via @code{get-internal-run-time}, | |
99 | ;;; how much CPU time (system and user -- which is also what | |
100 | ;;; @code{ITIMER_PROF} tracks), has elapsed while code has been executing | |
101 | ;;; within a statprof-start/stop block. | |
102 | ;;; | |
103 | ;;; The profiler also tries to avoid counting or timing its own code as | |
104 | ;;; much as possible. | |
105 | ;;; | |
47f3ce52 AW |
106 | ;;; Code: |
107 | ||
47f3ce52 AW |
108 | (define-module (statprof) |
109 | #:use-module (srfi srfi-1) | |
62fd93e2 | 110 | #:use-module (srfi srfi-9) |
e4a8775d | 111 | #:use-module (srfi srfi-9 gnu) |
47f3ce52 | 112 | #:autoload (ice-9 format) (format) |
e1138ba1 AW |
113 | #:use-module (system vm vm) |
114 | #:use-module (system vm frame) | |
3f9f4a2d | 115 | #:use-module (system vm debug) |
e1138ba1 | 116 | #:use-module (system vm program) |
47f3ce52 AW |
117 | #:export (statprof-active? |
118 | statprof-start | |
119 | statprof-stop | |
120 | statprof-reset | |
121 | ||
122 | statprof-accumulated-time | |
123 | statprof-sample-count | |
124 | statprof-fold-call-data | |
125 | statprof-proc-call-data | |
126 | statprof-call-data-name | |
127 | statprof-call-data-calls | |
128 | statprof-call-data-cum-samples | |
129 | statprof-call-data-self-samples | |
130 | statprof-call-data->stats | |
131 | ||
132 | statprof-stats-proc-name | |
ee3f9604 | 133 | statprof-stats-proc-source |
47f3ce52 AW |
134 | statprof-stats-%-time-in-proc |
135 | statprof-stats-cum-secs-in-proc | |
136 | statprof-stats-self-secs-in-proc | |
137 | statprof-stats-calls | |
138 | statprof-stats-self-secs-per-call | |
139 | statprof-stats-cum-secs-per-call | |
140 | ||
141 | statprof-display | |
91db6c4f AW |
142 | statprof-display-anomalies |
143 | statprof-display-anomolies ; Deprecated spelling. | |
47f3ce52 AW |
144 | |
145 | statprof-fetch-stacks | |
146 | statprof-fetch-call-tree | |
147 | ||
e1138ba1 | 148 | statprof |
2d239a78 AW |
149 | with-statprof |
150 | ||
151 | gcprof)) | |
47f3ce52 AW |
152 | |
153 | ||
1145f406 AW |
154 | ;;; ~ Implementation notes ~ |
155 | ;;; | |
156 | ;;; Statprof can be divided into two pieces: data collection and data | |
157 | ;;; analysis. | |
158 | ;;; | |
159 | ;;; The data collection runs concurrently with the program, and is | |
160 | ;;; designed to be as cheap as possible. The main data collection | |
161 | ;;; instrument is the stack sampler, driven by SIGPROF signals that are | |
162 | ;;; scheduled with periodic setitimer calls. The stack sampler simply | |
163 | ;;; looks at every frame on the stack, and writes a representation of | |
164 | ;;; the frame's procedure into a growable buffer. | |
165 | ;;; | |
166 | ;;; For most frames, this representation is the instruction pointer of | |
167 | ;;; that frame, because it's cheap to get and you can map from | |
168 | ;;; instruction pointer to procedure fairly cheaply. This won't | |
169 | ;;; distinguish between different closures which share the same code, | |
170 | ;;; but that is usually what we want anyway. | |
171 | ;;; | |
172 | ;;; One case in which we do want to distinguish closures is the case of | |
173 | ;;; primitive procedures. If slot 0 in the frame is a primitive | |
174 | ;;; procedure, we record the procedure's name into the buffer instead of | |
175 | ;;; the IP. It's fairly cheap to check whether a value is a primitive | |
176 | ;;; procedure, and then get its name, as its name is stored in the | |
177 | ;;; closure data. Calling procedure-name in the stack sampler isn't | |
178 | ;;; something you want to do for other kinds of procedures, though, as | |
179 | ;;; that involves grovelling the debug information. | |
180 | ;;; | |
181 | ;;; The other part of data collection is the exact call counter, which | |
182 | ;;; uses the VM's "apply" hook to record each procedure call. | |
183 | ;;; Naturally, this is quite expensive, and it is off by default. | |
184 | ;;; Running code at every procedure call effectively penalizes procedure | |
185 | ;;; calls. Still, it's useful sometimes. If the profiler state has a | |
186 | ;;; call-counts table, then calls will be counted. As with the stack | |
187 | ;;; counter, usually the key in the hash table is the code pointer of | |
188 | ;;; the procedure being called, except for primitive procedures, in | |
189 | ;;; which case it is the name of the primitive. The call counter can | |
190 | ;;; also see calls of non-programs, for example in the case of | |
191 | ;;; applicable structs. In that case the key is the procedure itself. | |
192 | ;;; | |
193 | ;;; After collection is finished, the data can be analyzed. The first | |
194 | ;;; step is usually to run over the stack traces, tabulating sample | |
195 | ;;; counts by procedure; the stack-samples->procedure-data does that. | |
196 | ;;; The result of stack-samples->procedure-data is a hash table mapping | |
197 | ;;; procedures to "call data" records. The call data values are exposed | |
198 | ;;; to users via the statprof-fold-call-data procedure. | |
199 | ;;; | |
200 | ;;; Usually all the analysis is triggered by calling statprof-display, | |
201 | ;;; or having the statprof procedure call it for you. | |
202 | ;;; | |
203 | ;;; The other thing we can do is to look at the stacks themselves, for | |
204 | ;;; example via statprof-fetch-call-tree. | |
205 | ;;; | |
206 | ||
207 | ;;; ~ Threads and state ~ | |
208 | ;;; | |
209 | ;;; The state of the profiler is contained in a <state> record, which is | |
210 | ;;; bound to a thread-local parameter. The accurate call counter uses | |
211 | ;;; the VM apply hook, which is also local to the current thread, so all | |
212 | ;;; is good there. | |
213 | ;;; | |
214 | ;;; The problem comes in the statistical stack sampler's use of | |
215 | ;;; `setitimer' and SIGPROF. The timer manipulated by setitimer is a | |
216 | ;;; whole-process timer, so it decrements as other threads execute, | |
217 | ;;; which is the wrong thing if you want to profile just one thread. On | |
218 | ;;; the other hand, SIGPROF is delivered to the process as a whole, | |
219 | ;;; which is fine given Guile's signal-handling thread, but then only | |
220 | ;;; delivered to the thread running statprof, which isn't the right | |
221 | ;;; thing if you want to profile the whole system. | |
222 | ;;; | |
223 | ;;; The summary is that statprof works more or less well as a per-thread | |
224 | ;;; profiler if no other threads are running on their own when | |
225 | ;;; profiling. If the other threads are running on behalf of the thread | |
226 | ;;; being profiled (as via futures or parallel marking) things still | |
227 | ;;; mostly work as expected. You can run statprof in one thread, | |
228 | ;;; finish, and then run statprof in another thread, and the profile | |
229 | ;;; runs won't affect each other. But if you want true per-thread | |
230 | ;;; profiles when other things are happening in the process, including | |
231 | ;;; other statprof runs, or whole-process profiles with per-thread | |
232 | ;;; breakdowns, the use of setitimer currently prevents that. | |
233 | ;;; | |
234 | ;;; The solution would be to switch to POSIX.1-2001's timer_create(2), | |
235 | ;;; and to add some more threading-related API to statprof. Some other | |
236 | ;;; day. | |
237 | ;;; | |
47f3ce52 | 238 | |
62fd93e2 AW |
239 | (define-record-type <state> |
240 | (make-state accumulated-time last-start-time sample-count | |
19bf8caf | 241 | sampling-period remaining-prof-time profile-level |
cd073eb4 | 242 | call-counts gc-time-taken inside-profiler? |
6bceec32 | 243 | prev-sigprof-handler outer-cut buffer buffer-pos) |
62fd93e2 AW |
244 | state? |
245 | ;; Total time so far. | |
246 | (accumulated-time accumulated-time set-accumulated-time!) | |
247 | ;; Start-time when timer is active. | |
248 | (last-start-time last-start-time set-last-start-time!) | |
249 | ;; Total count of sampler calls. | |
250 | (sample-count sample-count set-sample-count!) | |
19bf8caf AW |
251 | ;; Microseconds. |
252 | (sampling-period sampling-period set-sampling-period!) | |
62fd93e2 AW |
253 | ;; Time remaining when prof suspended. |
254 | (remaining-prof-time remaining-prof-time set-remaining-prof-time!) | |
255 | ;; For user start/stop nesting. | |
256 | (profile-level profile-level set-profile-level!) | |
3f9f4a2d AW |
257 | ;; Hash table mapping ip -> call count, or #f if not counting calls. |
258 | (call-counts call-counts set-call-counts!) | |
62fd93e2 AW |
259 | ;; GC time between statprof-start and statprof-stop. |
260 | (gc-time-taken gc-time-taken set-gc-time-taken!) | |
56bfce7c | 261 | ;; True if we are inside the profiler. |
3072d762 | 262 | (inside-profiler? inside-profiler? set-inside-profiler?!) |
6bceec32 | 263 | ;; Previous sigprof handler. |
3f9f4a2d | 264 | (prev-sigprof-handler prev-sigprof-handler set-prev-sigprof-handler!) |
6bceec32 AW |
265 | ;; Outer stack cut, or 0. |
266 | (outer-cut outer-cut) | |
3f9f4a2d AW |
267 | ;; Stack samples. |
268 | (buffer buffer set-buffer!) | |
269 | (buffer-pos buffer-pos set-buffer-pos!)) | |
62fd93e2 AW |
270 | |
271 | (define profiler-state (make-parameter #f)) | |
272 | ||
3f9f4a2d AW |
273 | (define (fresh-buffer) |
274 | (make-vector 1024 #f)) | |
275 | ||
276 | (define (expand-buffer buf) | |
277 | (let* ((size (vector-length buf)) | |
278 | (new (make-vector (* size 2) #f))) | |
279 | (vector-move-left! buf 0 (vector-length buf) new 0) | |
280 | new)) | |
281 | ||
4eb1fb9b | 282 | (define* (fresh-profiler-state #:key (count-calls? #f) |
6bceec32 AW |
283 | (sampling-period 10000) |
284 | (outer-cut 0)) | |
cd073eb4 AW |
285 | (make-state 0 #f 0 |
286 | sampling-period 0 0 | |
287 | (and count-calls? (make-hash-table)) 0 #f | |
6bceec32 | 288 | #f outer-cut (fresh-buffer) 0)) |
4eb1fb9b | 289 | |
62fd93e2 AW |
290 | (define (ensure-profiler-state) |
291 | (or (profiler-state) | |
4eb1fb9b | 292 | (let ((state (fresh-profiler-state))) |
62fd93e2 AW |
293 | (profiler-state state) |
294 | state))) | |
47f3ce52 | 295 | |
45a7de82 AW |
296 | (define (existing-profiler-state) |
297 | (or (profiler-state) | |
298 | (error "expected there to be a profiler state"))) | |
299 | ||
62fd93e2 AW |
300 | (define (accumulate-time state stop-time) |
301 | (set-accumulated-time! state | |
302 | (+ (accumulated-time state) | |
62fd93e2 | 303 | (- stop-time (last-start-time state))))) |
47f3ce52 | 304 | |
47f3ce52 AW |
305 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
306 | ;; SIGPROF handler | |
307 | ||
e4a8775d | 308 | (define (sample-stack-procs state stack) |
3f9f4a2d AW |
309 | (set-sample-count! state (+ (sample-count state) 1)) |
310 | ||
311 | (let lp ((frame (stack-ref stack 0)) | |
6bceec32 | 312 | (len (stack-length stack)) |
3f9f4a2d AW |
313 | (buffer (buffer state)) |
314 | (pos (buffer-pos state))) | |
315 | (define (write-sample sample) | |
316 | (vector-set! buffer pos sample)) | |
317 | (define (continue pos) | |
6bceec32 | 318 | (lp (frame-previous frame) (1- len) buffer pos)) |
3f9f4a2d AW |
319 | (define (write-sample-and-continue sample) |
320 | (write-sample sample) | |
321 | (continue (1+ pos))) | |
322 | (cond | |
323 | ((= pos (vector-length buffer)) | |
6bceec32 AW |
324 | (lp frame len (expand-buffer buffer) pos)) |
325 | ((or (zero? len) (not frame)) | |
3f9f4a2d AW |
326 | (write-sample #f) |
327 | (set-buffer! state buffer) | |
328 | (set-buffer-pos! state (1+ pos))) | |
329 | (else | |
330 | (let ((proc (frame-procedure frame))) | |
1145f406 AW |
331 | (write-sample-and-continue (if (primitive? proc) |
332 | (procedure-name proc) | |
333 | (frame-instruction-pointer frame)))))))) | |
47f3ce52 | 334 | |
19bf8caf | 335 | (define (reset-sigprof-timer usecs) |
e68ed839 AW |
336 | ;; Guile's setitimer binding is terrible. |
337 | (let ((prev (setitimer ITIMER_PROF 0 0 0 usecs))) | |
338 | (+ (* (caadr prev) #e1e6) (cdadr prev)))) | |
19bf8caf | 339 | |
47f3ce52 | 340 | (define (profile-signal-handler sig) |
45a7de82 | 341 | (define state (existing-profiler-state)) |
62fd93e2 | 342 | |
56bfce7c | 343 | (set-inside-profiler?! state #t) |
47f3ce52 | 344 | |
cad444e3 AW |
345 | (when (positive? (profile-level state)) |
346 | (let* ((stop-time (get-internal-run-time)) | |
6bceec32 AW |
347 | ;; Cut down to the signal handler. Note that this will only |
348 | ;; work if statprof.scm is compiled; otherwise we get `eval' | |
349 | ;; on the stack instead, because if it's not compiled, | |
350 | ;; profile-signal-handler is a thunk that tail-calls eval. | |
351 | ;; Perhaps we should always compile the signal handler | |
352 | ;; instead. | |
353 | (stack (or (make-stack #t profile-signal-handler (outer-cut state)) | |
546efe25 AW |
354 | (pk 'what! (make-stack #t))))) |
355 | ||
356 | (sample-stack-procs state stack) | |
357 | (accumulate-time state stop-time) | |
358 | (set-last-start-time! state (get-internal-run-time)) | |
359 | ||
19bf8caf | 360 | (reset-sigprof-timer (sampling-period state)))) |
e1138ba1 | 361 | |
56bfce7c | 362 | (set-inside-profiler?! state #f)) |
47f3ce52 AW |
363 | |
364 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
365 | ;; Count total calls. | |
366 | ||
e1138ba1 | 367 | (define (count-call frame) |
3f9f4a2d AW |
368 | (let ((state (existing-profiler-state))) |
369 | (unless (inside-profiler? state) | |
370 | (accumulate-time state (get-internal-run-time)) | |
62fd93e2 | 371 | |
3f9f4a2d AW |
372 | (let* ((key (let ((proc (frame-procedure frame))) |
373 | (cond | |
374 | ((primitive? proc) (procedure-name proc)) | |
375 | ((program? proc) (program-code proc)) | |
376 | (else proc)))) | |
377 | (handle (hashv-create-handle! (call-counts state) key 0))) | |
378 | (set-cdr! handle (1+ (cdr handle)))) | |
47f3ce52 | 379 | |
3f9f4a2d | 380 | (set-last-start-time! state (get-internal-run-time))))) |
47f3ce52 AW |
381 | |
382 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
383 | ||
384 | (define (statprof-active?) | |
385 | "Returns @code{#t} if @code{statprof-start} has been called more times | |
386 | than @code{statprof-stop}, @code{#f} otherwise." | |
45a7de82 AW |
387 | (define state (profiler-state)) |
388 | (and state (positive? (profile-level state)))) | |
47f3ce52 AW |
389 | |
390 | ;; Do not call this from statprof internal functions -- user only. | |
13a977dd | 391 | (define* (statprof-start #:optional (state (ensure-profiler-state))) |
47f3ce52 AW |
392 | "Start the profiler.@code{}" |
393 | ;; After some head-scratching, I don't *think* I need to mask/unmask | |
394 | ;; signals here, but if I'm wrong, please let me know. | |
62fd93e2 | 395 | (set-profile-level! state (+ (profile-level state) 1)) |
cad444e3 | 396 | (when (= (profile-level state) 1) |
19bf8caf AW |
397 | (let ((rpt (remaining-prof-time state))) |
398 | (set-remaining-prof-time! state 0) | |
cad444e3 AW |
399 | ;; FIXME: Use per-thread run time. |
400 | (set-last-start-time! state (get-internal-run-time)) | |
3476a369 | 401 | (set-gc-time-taken! state (assq-ref (gc-stats) 'gc-time-taken)) |
3072d762 AW |
402 | (let ((prev (sigaction SIGPROF profile-signal-handler))) |
403 | (set-prev-sigprof-handler! state (car prev))) | |
19bf8caf | 404 | (reset-sigprof-timer (if (zero? rpt) (sampling-period state) rpt)) |
3f9f4a2d | 405 | (when (call-counts state) |
da169db2 AW |
406 | (add-hook! (vm-apply-hook) count-call) |
407 | (set-vm-trace-level! (1+ (vm-trace-level)))) | |
cad444e3 | 408 | #t))) |
47f3ce52 AW |
409 | |
410 | ;; Do not call this from statprof internal functions -- user only. | |
13a977dd | 411 | (define* (statprof-stop #:optional (state (ensure-profiler-state))) |
47f3ce52 AW |
412 | "Stop the profiler.@code{}" |
413 | ;; After some head-scratching, I don't *think* I need to mask/unmask | |
414 | ;; signals here, but if I'm wrong, please let me know. | |
62fd93e2 | 415 | (set-profile-level! state (- (profile-level state) 1)) |
cad444e3 | 416 | (when (zero? (profile-level state)) |
da169db2 AW |
417 | (when (call-counts state) |
418 | (set-vm-trace-level! (1- (vm-trace-level))) | |
419 | (remove-hook! (vm-apply-hook) count-call)) | |
cad444e3 | 420 | (set-gc-time-taken! state |
3476a369 | 421 | (- (assq-ref (gc-stats) 'gc-time-taken) |
cad444e3 | 422 | (gc-time-taken state))) |
cad444e3 AW |
423 | ;; I believe that we need to do this before getting the time |
424 | ;; (unless we want to make things even more complicated). | |
19bf8caf | 425 | (set-remaining-prof-time! state (reset-sigprof-timer 0)) |
cad444e3 | 426 | (accumulate-time state (get-internal-run-time)) |
3072d762 AW |
427 | (sigaction SIGPROF (prev-sigprof-handler state)) |
428 | (set-prev-sigprof-handler! state #f) | |
cad444e3 | 429 | (set-last-start-time! state #f))) |
47f3ce52 | 430 | |
e640b440 AW |
431 | (define* (statprof-reset sample-seconds sample-microseconds count-calls? |
432 | #:optional full-stacks?) | |
47f3ce52 AW |
433 | "Reset the statprof sampler interval to @var{sample-seconds} and |
434 | @var{sample-microseconds}. If @var{count-calls?} is true, arrange to | |
435 | instrument procedure calls as well as collecting statistical profiling | |
cd073eb4 AW |
436 | data. (The optional @var{full-stacks?} argument is deprecated; statprof |
437 | always collects full stacks.)" | |
4d0c358b | 438 | (when (statprof-active?) |
4eb1fb9b | 439 | (error "Can't reset profiler while profiler is running.")) |
3072d762 AW |
440 | (profiler-state |
441 | (fresh-profiler-state #:count-calls? count-calls? | |
442 | #:sampling-period (+ (* sample-seconds #e1e6) | |
cd073eb4 | 443 | sample-microseconds))) |
13a977dd | 444 | (values)) |
47f3ce52 | 445 | |
3f9f4a2d | 446 | (define-record-type call-data |
ee3f9604 | 447 | (make-call-data name printable source |
e3997e70 | 448 | call-count cum-sample-count self-sample-count) |
3f9f4a2d AW |
449 | call-data? |
450 | (name call-data-name) | |
451 | (printable call-data-printable) | |
ee3f9604 | 452 | (source call-data-source) |
3f9f4a2d AW |
453 | (call-count call-data-call-count set-call-data-call-count!) |
454 | (cum-sample-count call-data-cum-sample-count set-call-data-cum-sample-count!) | |
455 | (self-sample-count call-data-self-sample-count set-call-data-self-sample-count!)) | |
456 | ||
457 | (define (source->string source) | |
458 | (format #f "~a:~a:~a" | |
459 | (or (source-file source) "<current input>") | |
460 | (source-line-for-user source) | |
461 | (source-column source))) | |
462 | ||
463 | (define (program-debug-info-printable pdi) | |
464 | (let* ((addr (program-debug-info-addr pdi)) | |
465 | (name (or (and=> (program-debug-info-name pdi) symbol->string) | |
466 | (string-append "#x" (number->string addr 16)))) | |
467 | (loc (and=> (find-source-for-addr addr) source->string))) | |
468 | (if loc | |
469 | (string-append name " at " loc) | |
470 | name))) | |
471 | ||
472 | (define (addr->pdi addr cache) | |
473 | (cond | |
474 | ((hashv-get-handle cache addr) => cdr) | |
475 | (else | |
476 | (let ((data (find-program-debug-info addr))) | |
477 | (hashv-set! cache addr data) | |
478 | data)))) | |
479 | ||
480 | (define (addr->printable addr pdi) | |
ee3f9604 AW |
481 | (or (and=> (and=> pdi program-debug-info-name) symbol->string) |
482 | (string-append "anon #x" (number->string addr 16)))) | |
3f9f4a2d AW |
483 | |
484 | (define (inc-call-data-cum-sample-count! cd) | |
485 | (set-call-data-cum-sample-count! cd (1+ (call-data-cum-sample-count cd)))) | |
486 | (define (inc-call-data-self-sample-count! cd) | |
487 | (set-call-data-self-sample-count! cd (1+ (call-data-self-sample-count cd)))) | |
488 | ||
489 | (define (stack-samples->procedure-data state) | |
490 | (let ((table (make-hash-table)) | |
491 | (addr-cache (make-hash-table)) | |
492 | (call-counts (call-counts state)) | |
493 | (buffer (buffer state)) | |
494 | (len (buffer-pos state))) | |
495 | (define (addr->call-data addr) | |
496 | (let* ((pdi (addr->pdi addr addr-cache)) | |
497 | (entry (if pdi (program-debug-info-addr pdi) addr))) | |
498 | (or (hashv-ref table entry) | |
499 | (let ((data (make-call-data (and=> pdi program-debug-info-name) | |
500 | (addr->printable entry pdi) | |
ee3f9604 | 501 | (find-source-for-addr entry) |
3f9f4a2d AW |
502 | (and call-counts |
503 | (hashv-ref call-counts entry)) | |
504 | 0 | |
505 | 0))) | |
506 | (hashv-set! table entry data) | |
507 | data)))) | |
508 | ||
509 | (define (callee->call-data callee) | |
510 | (cond | |
511 | ((number? callee) (addr->call-data callee)) | |
512 | ((hashv-ref table callee)) | |
513 | (else | |
514 | (let ((data (make-call-data | |
515 | (cond ((procedure? callee) (procedure-name callee)) | |
516 | ;; a primitive | |
517 | ((symbol? callee) callee) | |
518 | (else #f)) | |
519 | (with-output-to-string (lambda () (write callee))) | |
ee3f9604 | 520 | #f |
3f9f4a2d AW |
521 | (and call-counts (hashv-ref call-counts callee)) |
522 | 0 | |
523 | 0))) | |
524 | (hashv-set! table callee data) | |
525 | data)))) | |
526 | ||
527 | (when call-counts | |
528 | (hash-for-each (lambda (callee count) | |
529 | (callee->call-data callee)) | |
530 | call-counts)) | |
531 | ||
532 | (let visit-stacks ((pos 0)) | |
533 | (cond | |
534 | ((< pos len) | |
535 | ;; FIXME: if we are counting all procedure calls, and | |
536 | ;; count-call is on the stack, we need to not count the part | |
537 | ;; of the stack that is within count-call. | |
538 | (inc-call-data-self-sample-count! | |
539 | (callee->call-data (vector-ref buffer pos))) | |
540 | (let visit-stack ((pos pos)) | |
cd073eb4 AW |
541 | (cond |
542 | ((vector-ref buffer pos) | |
543 | => (lambda (callee) | |
544 | (inc-call-data-cum-sample-count! (callee->call-data callee)) | |
545 | (visit-stack (1+ pos)))) | |
546 | (else | |
547 | (visit-stacks (1+ pos)))))) | |
3f9f4a2d AW |
548 | (else table))))) |
549 | ||
cd073eb4 AW |
550 | (define (stack-samples->callee-lists state) |
551 | (let ((buffer (buffer state)) | |
552 | (len (buffer-pos state))) | |
553 | (let visit-stacks ((pos 0) (out '())) | |
554 | (cond | |
555 | ((< pos len) | |
556 | ;; FIXME: if we are counting all procedure calls, and | |
557 | ;; count-call is on the stack, we need to not count the part | |
558 | ;; of the stack that is within count-call. | |
559 | (let visit-stack ((pos pos) (stack '())) | |
560 | (cond | |
561 | ((vector-ref buffer pos) | |
562 | => (lambda (callee) | |
563 | (visit-stack (1+ pos) (cons callee stack)))) | |
564 | (else | |
565 | (visit-stacks (1+ pos) (cons (reverse stack) out)))))) | |
566 | (else (reverse out)))))) | |
567 | ||
a234ab92 AW |
568 | (define* (statprof-fold-call-data proc init #:optional |
569 | (state (existing-profiler-state))) | |
47f3ce52 AW |
570 | "Fold @var{proc} over the call-data accumulated by statprof. Cannot be |
571 | called while statprof is active. @var{proc} should take two arguments, | |
572 | @code{(@var{call-data} @var{prior-result})}. | |
573 | ||
574 | Note that a given proc-name may appear multiple times, but if it does, | |
575 | it represents different functions with the same name." | |
4d0c358b AW |
576 | (when (statprof-active?) |
577 | (error "Can't call statprof-fold-call-data while profiler is running.")) | |
47f3ce52 AW |
578 | (hash-fold |
579 | (lambda (key value prior-result) | |
580 | (proc value prior-result)) | |
581 | init | |
a234ab92 | 582 | (stack-samples->procedure-data state))) |
47f3ce52 | 583 | |
a234ab92 AW |
584 | (define* (statprof-proc-call-data proc #:optional |
585 | (state (existing-profiler-state))) | |
47f3ce52 AW |
586 | "Returns the call-data associated with @var{proc}, or @code{#f} if |
587 | none is available." | |
4d0c358b AW |
588 | (when (statprof-active?) |
589 | (error "Can't call statprof-proc-call-data while profiler is running.")) | |
a234ab92 | 590 | (hashv-ref (stack-samples->procedure-data state) |
3f9f4a2d AW |
591 | (cond |
592 | ((primitive? proc) (procedure-name proc)) | |
593 | ((program? proc) (program-code proc)) | |
594 | (else (program-code proc))))) | |
47f3ce52 AW |
595 | |
596 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
597 | ;; Stats | |
598 | ||
e3997e70 | 599 | (define-record-type stats |
ee3f9604 AW |
600 | (make-stats proc-name proc-source |
601 | %-time-in-proc cum-secs-in-proc self-secs-in-proc | |
e3997e70 AW |
602 | calls self-secs-per-call cum-secs-per-call) |
603 | stats? | |
604 | (proc-name statprof-stats-proc-name) | |
ee3f9604 | 605 | (proc-source statprof-stats-proc-source) |
e3997e70 AW |
606 | (%-time-in-proc statprof-stats-%-time-in-proc) |
607 | (cum-secs-in-proc statprof-stats-cum-secs-in-proc) | |
608 | (self-secs-in-proc statprof-stats-self-secs-in-proc) | |
609 | (calls statprof-stats-calls) | |
610 | (self-secs-per-call statprof-stats-self-secs-per-call) | |
611 | (cum-secs-per-call statprof-stats-cum-secs-per-call)) | |
612 | ||
47f3ce52 AW |
613 | (define (statprof-call-data->stats call-data) |
614 | "Returns an object of type @code{statprof-stats}." | |
45a7de82 | 615 | (define state (existing-profiler-state)) |
62fd93e2 | 616 | |
ee3f9604 AW |
617 | (let* ((proc-name (call-data-name call-data)) |
618 | (proc-source (and=> (call-data-source call-data) source->string)) | |
47f3ce52 AW |
619 | (self-samples (call-data-self-sample-count call-data)) |
620 | (cum-samples (call-data-cum-sample-count call-data)) | |
a234ab92 AW |
621 | (all-samples (statprof-sample-count state)) |
622 | (secs-per-sample (/ (statprof-accumulated-time state) | |
623 | (statprof-sample-count state))) | |
3f9f4a2d AW |
624 | (num-calls (and (call-counts state) |
625 | (statprof-call-data-calls call-data)))) | |
47f3ce52 | 626 | |
ee3f9604 AW |
627 | (make-stats (or proc-name |
628 | ;; If there is no name and no source, fall back to | |
629 | ;; printable. | |
630 | (and (not proc-source) (call-data-printable call-data))) | |
631 | proc-source | |
e3997e70 AW |
632 | (* (/ self-samples all-samples) 100.0) |
633 | (* cum-samples secs-per-sample 1.0) | |
634 | (* self-samples secs-per-sample 1.0) | |
635 | num-calls | |
636 | (and num-calls ;; maybe we only sampled in children | |
637 | (if (zero? self-samples) 0.0 | |
638 | (/ (* self-samples secs-per-sample) 1.0 num-calls))) | |
639 | (and num-calls ;; cum-samples must be positive | |
640 | (/ (* cum-samples secs-per-sample) | |
641 | 1.0 | |
642 | ;; num-calls might be 0 if we entered statprof during the | |
643 | ;; dynamic extent of the call | |
644 | (max num-calls 1)))))) | |
47f3ce52 AW |
645 | |
646 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
647 | ||
648 | (define (stats-sorter x y) | |
649 | (let ((diff (- (statprof-stats-self-secs-in-proc x) | |
650 | (statprof-stats-self-secs-in-proc y)))) | |
651 | (positive? | |
652 | (if (= diff 0) | |
653 | (- (statprof-stats-cum-secs-in-proc x) | |
654 | (statprof-stats-cum-secs-in-proc y)) | |
655 | diff)))) | |
656 | ||
91db6c4f AW |
657 | (define* (statprof-display #:optional (port (current-output-port)) |
658 | (state (existing-profiler-state))) | |
47f3ce52 AW |
659 | "Displays a gprof-like summary of the statistics collected. Unless an |
660 | optional @var{port} argument is passed, uses the current output port." | |
47f3ce52 | 661 | (cond |
a234ab92 | 662 | ((zero? (statprof-sample-count state)) |
47f3ce52 AW |
663 | (format port "No samples recorded.\n")) |
664 | (else | |
665 | (let* ((stats-list (statprof-fold-call-data | |
666 | (lambda (data prior-value) | |
667 | (cons (statprof-call-data->stats data) | |
668 | prior-value)) | |
a234ab92 AW |
669 | '() |
670 | state)) | |
47f3ce52 AW |
671 | (sorted-stats (sort stats-list stats-sorter))) |
672 | ||
673 | (define (display-stats-line stats) | |
3f9f4a2d AW |
674 | (format port "~6,2f ~9,2f ~9,2f" |
675 | (statprof-stats-%-time-in-proc stats) | |
676 | (statprof-stats-cum-secs-in-proc stats) | |
677 | (statprof-stats-self-secs-in-proc stats)) | |
678 | (if (call-counts state) | |
679 | (if (statprof-stats-calls stats) | |
680 | (format port " ~7d ~8,2f ~8,2f " | |
681 | (statprof-stats-calls stats) | |
682 | (* 1000 (statprof-stats-self-secs-per-call stats)) | |
683 | (* 1000 (statprof-stats-cum-secs-per-call stats))) | |
684 | (format port " ")) | |
685 | (display " " port)) | |
ee3f9604 AW |
686 | (let ((source (statprof-stats-proc-source stats)) |
687 | (name (statprof-stats-proc-name stats))) | |
688 | (when source | |
689 | (display source port) | |
690 | (when name | |
691 | (display ":" port))) | |
692 | (when name | |
693 | (display name port)) | |
694 | (newline port))) | |
47f3ce52 | 695 | |
3f9f4a2d | 696 | (if (call-counts state) |
47f3ce52 AW |
697 | (begin |
698 | (format port "~5a ~10a ~7a ~8a ~8a ~8a ~8@a\n" | |
699 | "% " "cumulative" "self" "" "self" "total" "") | |
ee3f9604 AW |
700 | (format port "~5a ~9a ~8a ~8a ~8a ~8a ~a\n" |
701 | "time" "seconds" "seconds" "calls" "ms/call" "ms/call" "procedure")) | |
47f3ce52 | 702 | (begin |
ee3f9604 | 703 | (format port "~5a ~10a ~7a ~8a\n" |
47f3ce52 | 704 | "%" "cumulative" "self" "") |
ee3f9604 AW |
705 | (format port "~5a ~10a ~7a ~a\n" |
706 | "time" "seconds" "seconds" "procedure"))) | |
47f3ce52 AW |
707 | |
708 | (for-each display-stats-line sorted-stats) | |
709 | ||
710 | (display "---\n" port) | |
a234ab92 | 711 | (simple-format #t "Sample count: ~A\n" (statprof-sample-count state)) |
47f3ce52 | 712 | (simple-format #t "Total time: ~A seconds (~A seconds in GC)\n" |
a234ab92 | 713 | (statprof-accumulated-time state) |
3476a369 AW |
714 | (/ (gc-time-taken state) |
715 | 1.0 internal-time-units-per-second)))))) | |
47f3ce52 | 716 | |
91db6c4f AW |
717 | (define* (statprof-display-anomalies #:optional (state |
718 | (existing-profiler-state))) | |
719 | "A sanity check that attempts to detect anomalies in statprof's | |
47f3ce52 AW |
720 | statistics.@code{}" |
721 | (statprof-fold-call-data | |
722 | (lambda (data prior-value) | |
3f9f4a2d | 723 | (when (and (call-counts state) |
cad444e3 AW |
724 | (zero? (call-data-call-count data)) |
725 | (positive? (call-data-cum-sample-count data))) | |
726 | (simple-format #t | |
727 | "==[~A ~A ~A]\n" | |
728 | (call-data-name data) | |
729 | (call-data-call-count data) | |
730 | (call-data-cum-sample-count data)))) | |
a234ab92 AW |
731 | #f |
732 | state) | |
733 | (simple-format #t "Total time: ~A\n" (statprof-accumulated-time state)) | |
734 | (simple-format #t "Sample count: ~A\n" (statprof-sample-count state))) | |
47f3ce52 | 735 | |
91db6c4f AW |
736 | (define (statprof-display-anomolies) |
737 | (issue-deprecation-warning "statprof-display-anomolies is a misspelling. " | |
738 | "Use statprof-display-anomalies instead.") | |
739 | (statprof-display-anomalies)) | |
740 | ||
741 | (define* (statprof-accumulated-time #:optional (state | |
742 | (existing-profiler-state))) | |
47f3ce52 | 743 | "Returns the time accumulated during the last statprof run.@code{}" |
91db6c4f | 744 | (/ (accumulated-time state) 1.0 internal-time-units-per-second)) |
47f3ce52 | 745 | |
91db6c4f | 746 | (define* (statprof-sample-count #:optional (state (existing-profiler-state))) |
47f3ce52 | 747 | "Returns the number of samples taken during the last statprof run.@code{}" |
91db6c4f | 748 | (sample-count state)) |
47f3ce52 AW |
749 | |
750 | (define statprof-call-data-name call-data-name) | |
751 | (define statprof-call-data-calls call-data-call-count) | |
752 | (define statprof-call-data-cum-samples call-data-cum-sample-count) | |
753 | (define statprof-call-data-self-samples call-data-self-sample-count) | |
754 | ||
91db6c4f | 755 | (define* (statprof-fetch-stacks #:optional (state (existing-profiler-state))) |
47f3ce52 | 756 | "Returns a list of stacks, as they were captured since the last call |
cd073eb4 AW |
757 | to @code{statprof-reset}." |
758 | (stack-samples->callee-lists state)) | |
47f3ce52 AW |
759 | |
760 | (define procedure=? | |
663212bb AW |
761 | (lambda (a b) |
762 | (cond | |
763 | ((eq? a b)) | |
0bd1e9c6 | 764 | ((and (program? a) (program? b)) |
d1100525 | 765 | (eq? (program-code a) (program-code b))) |
663212bb AW |
766 | (else |
767 | #f)))) | |
47f3ce52 AW |
768 | |
769 | ;; tree ::= (car n . tree*) | |
770 | ||
771 | (define (lists->trees lists equal?) | |
772 | (let lp ((in lists) (n-terminal 0) (tails '())) | |
773 | (cond | |
774 | ((null? in) | |
775 | (let ((trees (map (lambda (tail) | |
776 | (cons (car tail) | |
777 | (lists->trees (cdr tail) equal?))) | |
778 | tails))) | |
779 | (cons (apply + n-terminal (map cadr trees)) | |
780 | (sort trees | |
781 | (lambda (a b) (> (cadr a) (cadr b))))))) | |
782 | ((null? (car in)) | |
783 | (lp (cdr in) (1+ n-terminal) tails)) | |
784 | ((find (lambda (x) (equal? (car x) (caar in))) | |
785 | tails) | |
786 | => (lambda (tail) | |
787 | (lp (cdr in) | |
788 | n-terminal | |
789 | (assq-set! tails | |
790 | (car tail) | |
791 | (cons (cdar in) (cdr tail)))))) | |
792 | (else | |
793 | (lp (cdr in) | |
794 | n-terminal | |
795 | (acons (caar in) (list (cdar in)) tails)))))) | |
796 | ||
91db6c4f | 797 | (define* (statprof-fetch-call-tree #:optional (state (existing-profiler-state))) |
47f3ce52 AW |
798 | "Return a call tree for the previous statprof run. |
799 | ||
800 | The return value is a list of nodes, each of which is of the type: | |
801 | @code | |
802 | node ::= (@var{proc} @var{count} . @var{nodes}) | |
803 | @end code" | |
cd073eb4 AW |
804 | (define (callee->printable callee) |
805 | (cond | |
806 | ((number? callee) | |
807 | (addr->printable callee (find-program-debug-info callee))) | |
808 | (else | |
809 | (with-output-to-string (lambda () (write callee)))))) | |
810 | (define (memoizev/1 proc table) | |
811 | (lambda (x) | |
812 | (cond | |
813 | ((hashv-get-handle table x) => cdr) | |
814 | (else | |
815 | (let ((res (proc x))) | |
816 | (hashv-set! table x res) | |
817 | res))))) | |
818 | (let ((callee->printable (memoizev/1 callee->printable (make-hash-table)))) | |
819 | (cons #t (lists->trees (map (lambda (callee-list) | |
820 | (map callee->printable callee-list)) | |
821 | (stack-samples->callee-lists state)) | |
822 | equal?)))) | |
47f3ce52 | 823 | |
6bceec32 AW |
824 | (define (call-thunk thunk) |
825 | (thunk) | |
826 | (values)) | |
827 | ||
e1138ba1 | 828 | (define* (statprof thunk #:key (loop 1) (hz 100) (count-calls? #f) |
cd073eb4 | 829 | (port (current-output-port)) full-stacks?) |
e1138ba1 AW |
830 | "Profiles the execution of @var{thunk}. |
831 | ||
832 | The stack will be sampled @var{hz} times per second, and the thunk itself will | |
833 | be called @var{loop} times. | |
834 | ||
835 | If @var{count-calls?} is true, all procedure calls will be recorded. This | |
cd073eb4 | 836 | operation is somewhat expensive." |
e1138ba1 | 837 | |
13a977dd AW |
838 | (let ((state (fresh-profiler-state #:count-calls? count-calls? |
839 | #:sampling-period | |
6bceec32 AW |
840 | (inexact->exact (round (/ 1e6 hz))) |
841 | #:outer-cut call-thunk))) | |
fd5dfcce AW |
842 | (parameterize ((profiler-state state)) |
843 | (dynamic-wind | |
844 | (lambda () | |
13a977dd | 845 | (statprof-start state)) |
fd5dfcce AW |
846 | (lambda () |
847 | (let lp ((i loop)) | |
848 | (unless (zero? i) | |
6bceec32 | 849 | (call-thunk thunk) |
fd5dfcce AW |
850 | (lp (1- i))))) |
851 | (lambda () | |
13a977dd AW |
852 | (statprof-stop state) |
853 | (statprof-display port state)))))) | |
e1138ba1 | 854 | |
47f3ce52 AW |
855 | (define-macro (with-statprof . args) |
856 | "Profiles the expressions in its body. | |
857 | ||
858 | Keyword arguments: | |
859 | ||
860 | @table @code | |
861 | @item #:loop | |
862 | Execute the body @var{loop} number of times, or @code{#f} for no looping | |
863 | ||
864 | default: @code{#f} | |
865 | @item #:hz | |
866 | Sampling rate | |
867 | ||
868 | default: @code{20} | |
869 | @item #:count-calls? | |
870 | Whether to instrument each function call (expensive) | |
871 | ||
47f3ce52 AW |
872 | default: @code{#f} |
873 | @end table" | |
874 | (define (kw-arg-ref kw args def) | |
875 | (cond | |
876 | ((null? args) (error "Invalid macro body")) | |
877 | ((keyword? (car args)) | |
878 | (if (eq? (car args) kw) | |
879 | (cadr args) | |
880 | (kw-arg-ref kw (cddr args) def))) | |
881 | ((eq? kw #f def) ;; asking for the body | |
882 | args) | |
883 | (else def))) ;; kw not found | |
e1138ba1 AW |
884 | `((@ (statprof) statprof) |
885 | (lambda () ,@(kw-arg-ref #f args #f)) | |
886 | #:loop ,(kw-arg-ref #:loop args 1) | |
887 | #:hz ,(kw-arg-ref #:hz args 100) | |
888 | #:count-calls? ,(kw-arg-ref #:count-calls? args #f) | |
889 | #:full-stacks? ,(kw-arg-ref #:full-stacks? args #f))) | |
890 | ||
a234ab92 | 891 | (define* (gcprof thunk #:key (loop 1) full-stacks? (port (current-output-port))) |
2d239a78 AW |
892 | "Do an allocation profile of the execution of @var{thunk}. |
893 | ||
894 | The stack will be sampled soon after every garbage collection, yielding | |
895 | an approximate idea of what is causing allocation in your program. | |
896 | ||
897 | Since GC does not occur very frequently, you may need to use the | |
898 | @var{loop} parameter, to cause @var{thunk} to be called @var{loop} | |
cd073eb4 | 899 | times." |
2d239a78 | 900 | |
6bceec32 | 901 | (let ((state (fresh-profiler-state #:outer-cut call-thunk))) |
fd5dfcce | 902 | (parameterize ((profiler-state state)) |
fd5dfcce | 903 | (define (gc-callback) |
a7ede58d | 904 | (unless (inside-profiler? state) |
fd5dfcce AW |
905 | (set-inside-profiler?! state #t) |
906 | ||
fd5dfcce AW |
907 | (let ((stop-time (get-internal-run-time)) |
908 | ;; Cut down to gc-callback, and then one before (the | |
909 | ;; after-gc async). See the note in profile-signal-handler | |
910 | ;; also. | |
6bceec32 | 911 | (stack (or (make-stack #t gc-callback (outer-cut state) 1) |
fd5dfcce AW |
912 | (pk 'what! (make-stack #t))))) |
913 | (sample-stack-procs state stack) | |
914 | (accumulate-time state stop-time) | |
915 | (set-last-start-time! state (get-internal-run-time))) | |
cd073eb4 | 916 | |
a7ede58d | 917 | (set-inside-profiler?! state #f))) |
fd5dfcce AW |
918 | |
919 | (dynamic-wind | |
920 | (lambda () | |
a7ede58d AW |
921 | (set-profile-level! state 1) |
922 | (set-last-start-time! state (get-internal-run-time)) | |
923 | (set-gc-time-taken! state (assq-ref (gc-stats) 'gc-time-taken)) | |
924 | (add-hook! after-gc-hook gc-callback)) | |
fd5dfcce AW |
925 | (lambda () |
926 | (let lp ((i loop)) | |
927 | (unless (zero? i) | |
6bceec32 | 928 | (call-thunk thunk) |
fd5dfcce AW |
929 | (lp (1- i))))) |
930 | (lambda () | |
a7ede58d AW |
931 | (remove-hook! after-gc-hook gc-callback) |
932 | (set-gc-time-taken! state | |
933 | (- (assq-ref (gc-stats) 'gc-time-taken) | |
934 | (gc-time-taken state))) | |
935 | (accumulate-time state (get-internal-run-time)) | |
936 | (set-profile-level! state 0) | |
a234ab92 | 937 | (statprof-display port state)))))) |