/[cmucl]/src/contrib/sprof/sprof.lisp
ViewVC logotype

Contents of /src/contrib/sprof/sprof.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Wed May 12 02:49:35 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, cross-sol-x86-base, sparc-tramp-assem-base, snapshot-2010-12, snapshot-2010-11, cross-sol-x86-merged, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-06, release-20b-pre1, release-20b-pre2, cross-sparc-branch-base, snapshot-2010-07, sparc-tramp-assem-2010-07-19, snapshot-2010-08, RELEASE_20b, cross-sol-x86-2010-12-20, HEAD
Branch point for: cross-sol-x86-branch, cross-sparc-branch, sparc-tramp-assem-branch, RELEASE-20B-BRANCH
Changes since 1.4: +1 -1 lines
Update call to PROVIDE to use the module name.  (Not really needed
since the modules use asdf now.)
1 ;;; Copyright (C) 2003 Gerd Moellmann <gerd.moellmann@t-online.de>
2 ;;; All rights reserved.
3 ;;;
4 ;;; Redistribution and use in source and binary forms, with or without
5 ;;; modification, are permitted provided that the following conditions
6 ;;; are met:
7 ;;;
8 ;;; 1. Redistributions of source code must retain the above copyright
9 ;;; notice, this list of conditions and the following disclaimer.
10 ;;; 2. Redistributions in binary form must reproduce the above copyright
11 ;;; notice, this list of conditions and the following disclaimer in the
12 ;;; documentation and/or other materials provided with the distribution.
13 ;;; 3. The name of the author may not be used to endorse or promote
14 ;;; products derived from this software without specific prior written
15 ;;; permission.
16 ;;;
17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
20 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
21 ;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
22 ;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
23 ;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
24 ;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
25 ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
26 ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
27 ;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
28 ;;; DAMAGE.
29
30 ;;; Statistical profiler for x86.
31
32 ;;; Overview:
33 ;;;
34 ;;; This profiler arranges for SIGPROF interrupts to interrupt a
35 ;;; running program at regular intervals. Each time a SIGPROF occurs,
36 ;;; the current program counter and return address is recorded in a
37 ;;; vector, until a configurable maximum number of samples have been
38 ;;; taken.
39 ;;;
40 ;;; A profiling report is generated from the samples array by
41 ;;; determining the Lisp functions corresponding to the recorded
42 ;;; addresses. Each program counter/return address pair forms one
43 ;;; edge in a call graph.
44
45 ;;; Problems:
46 ;;;
47 ;;; The code being generated on x86 makes determining callers reliably
48 ;;; something between extremely difficult and impossible. Example:
49 ;;;
50 ;;; 10979F00: .entry eval::eval-stack-args(arg-count)
51 ;;; 18: pop dword ptr [ebp-8]
52 ;;; 1B: lea esp, [ebp-32]
53 ;;; 1E: mov edi, edx
54 ;;;
55 ;;; 20: cmp ecx, 4
56 ;;; 23: jne L4
57 ;;; 29: mov [ebp-12], edi
58 ;;; 2C: mov dword ptr [ebp-16], #x28F0000B ; nil
59 ;;; ; No-arg-parsing entry point
60 ;;; 33: mov dword ptr [ebp-20], 0
61 ;;; 3A: jmp L3
62 ;;; 3C: L0: mov edx, esp
63 ;;; 3E: sub esp, 12
64 ;;; 41: mov eax, [#x10979EF8] ; #<FDEFINITION object for eval::eval-stack-pop>
65 ;;; 47: xor ecx, ecx
66 ;;; 49: mov [edx-4], ebp
67 ;;; 4C: mov ebp, edx
68 ;;; 4E: call dword ptr [eax+5]
69 ;;; 51: mov esp, ebx
70 ;;;
71 ;;; Suppose this function is interrupted by SIGPROF at 4E. At that
72 ;;; point, the frame pointer EBP has been modified so that the
73 ;;; original return address of the caller of eval-stack-args is no
74 ;;; longer where it can be found by x86-call-context, and the new
75 ;;; return address, for the call to eval-stack-pop, is not yet on the
76 ;;; stack. The effect is that x86-call-context returns something
77 ;;; bogus, which leads to wrong edges in the call graph.
78 ;;;
79 ;;; One thing that one might try is filtering cases where the program
80 ;;; is interrupted at a call instruction. But since the above example
81 ;;; of an interrupt at a call instruction isn't the only case where
82 ;;; the stack is something x86-call-context can't really cope with,
83 ;;; this is not a general solution. (*Check-plausible-return-pc-p* is
84 ;;; an attempt at filtering, but since it's not sufficiently reliable,
85 ;;; it's disabled for now.)
86 ;;;
87
88 ;;; Random ideas for implementation:
89 ;;;
90 ;;; * Show a disassembly of a function annotated with sampling
91 ;;; information.
92 ;;;
93 ;;; * Space profiler. Sample when new pages are allocated instead of
94 ;;; at SIGPROF.
95 ;;;
96 ;;; * Record a configurable number of callers up the stack. That
97 ;;; could give a more complete graph when there are many small
98 ;;; functions.
99 ;;;
100 ;;; * Print help strings for reports, include hints to the problem
101 ;;; explained above.
102 ;;;
103 ;;; * Make flat report the default since call-graph isn't that
104 ;;; reliable?
105
106 (eval-when (compile load eval)
107 (defpackage :statistical-profiler
108 (:nicknames :sprof)
109 (:use :cl :ext :unix :alien :system)
110 (:export #:*sample-interval* #:*max-samples*
111 #:start-sampling #:stop-sampling #:with-sampling
112 #:with-profiling #:start-profiling #:stop-profiling
113 #:reset #:report)))
114
115 (in-package :sprof)
116
117
118 ;;;; Graph Utilities
119
120 (defstruct (vertex (:constructor make-vertex)
121 (:constructor make-scc (scc-vertices edges)))
122 (visited nil :type boolean)
123 (root nil :type (or null vertex))
124 (dfn 0 :type fixnum)
125 (edges () :type list)
126 (scc-vertices () :type list))
127
128 (defstruct edge
129 (vertex (required-argument) :type vertex))
130
131 (defstruct graph
132 (vertices () :type list))
133
134 (declaim (inline scc-p))
135 (defun scc-p (vertex)
136 (not (null (vertex-scc-vertices vertex))))
137
138 (defmacro do-vertices ((vertex graph) &body body)
139 `(dolist (,vertex (graph-vertices ,graph))
140 ,@body))
141
142 (defmacro do-edges ((edge edge-to vertex) &body body)
143 `(dolist (,edge (vertex-edges ,vertex))
144 (let ((,edge-to (edge-vertex ,edge)))
145 ,@body)))
146
147 (defun self-cycle-p (vertex)
148 (do-edges (e to vertex)
149 (when (eq to vertex)
150 (return t))))
151
152 (defun map-vertices (fn vertices)
153 (dolist (v vertices)
154 (setf (vertex-visited v) nil))
155 (dolist (v vertices)
156 (unless (vertex-visited v)
157 (funcall fn v))))
158
159 ;;;
160 ;;; Eeko Nuutila, Eljas Soisalon-Soininen, around 1992. Improves on
161 ;;; Tarjan's original algorithm by not using the stack when processing
162 ;;; trivial components. Trivial components should appear frequently
163 ;;; in a call-graph such as ours, I think. Same complexity O(V+E) as
164 ;;; Tarjan.
165 ;;;
166 (defun strong-components (vertices)
167 (let ((in-component (make-array (length vertices)
168 :element-type 'boolean
169 :initial-element nil))
170 (stack ())
171 (components ())
172 (dfn -1))
173 (labels ((min-root (x y)
174 (let ((rx (vertex-root x))
175 (ry (vertex-root y)))
176 (if (< (vertex-dfn rx) (vertex-dfn ry))
177 rx
178 ry)))
179 (in-component (v)
180 (aref in-component (vertex-dfn v)))
181 ((setf in-component) (in v)
182 (setf (aref in-component (vertex-dfn v)) in))
183 (vertex-> (x y)
184 (> (vertex-dfn x) (vertex-dfn y)))
185 (visit (v)
186 (setf (vertex-dfn v) (incf dfn)
187 (in-component v) nil
188 (vertex-root v) v
189 (vertex-visited v) t)
190 (do-edges (e w v)
191 (unless (vertex-visited w)
192 (visit w))
193 (unless (in-component w)
194 (setf (vertex-root v) (min-root v w))))
195 (if (eq v (vertex-root v))
196 (loop while (and stack (vertex-> (car stack) v))
197 as w = (pop stack)
198 collect w into this-component
199 do (setf (in-component w) t)
200 finally
201 (setf (in-component v) t)
202 (push (cons v this-component) components))
203 (push v stack))))
204 (map-vertices #'visit vertices)
205 components)))
206
207 ;;;
208 ;;; Given a dag as a list of vertices, return the list sorted
209 ;;; topologically, children first.
210 ;;;
211 (defun topological-sort (dag)
212 (let ((sorted ())
213 (dfn -1))
214 (labels ((sort (v)
215 (setf (vertex-visited v) t)
216 (setf (vertex-dfn v) (incf dfn))
217 (dolist (e (vertex-edges v))
218 (unless (vertex-visited (edge-vertex e))
219 (sort (edge-vertex e))))
220 (push v sorted)))
221 (map-vertices #'sort dag)
222 (nreverse sorted))))
223
224 ;;;
225 ;;; Reduce graph G to a dag by coalescing strongly connected components
226 ;;; into vertices. Sort the result topologically.
227 ;;;
228 (defun reduce-graph (graph &optional (scc-constructor #'make-scc))
229 (collect ((sccs) (trivial))
230 (dolist (c (strong-components (graph-vertices graph)))
231 (if (or (cdr c) (self-cycle-p (car c)))
232 (collect ((outgoing))
233 (dolist (v c)
234 (do-edges (e w v)
235 (unless (member w c)
236 (outgoing e))))
237 (sccs (funcall scc-constructor c (outgoing))))
238 (trivial (car c))))
239 (dolist (scc (sccs))
240 (dolist (v (trivial))
241 (do-edges (e w v)
242 (when (member w (vertex-scc-vertices scc))
243 (setf (edge-vertex e) scc)))))
244 (setf (graph-vertices graph)
245 (topological-sort (nconc (sccs) (trivial))))))
246
247
248 ;;;; AA Trees
249
250 ;;;
251 ;;; An AA tree is a red-black tree with the extra condition that left
252 ;;; children may not be red. This condition simplifies the red-black
253 ;;; algorithm. It eliminates half of the restructuring cases, and
254 ;;; simplifies the delete algorithm.
255 ;;;
256
257 (defstruct (aa-node (:conc-name aa-))
258 (left nil :type (or null aa-node))
259 (right nil :type (or null aa-node))
260 (level 0 :type integer)
261 (data nil :type t))
262
263 (defvar *null-node*
264 (let ((node (make-aa-node)))
265 (setf (aa-left node) node)
266 (setf (aa-right node) node)
267 node))
268
269 (defstruct aa-tree
270 (root *null-node* :type aa-node))
271
272 (declaim (inline skew split rotate-with-left-child rotate-with-right-child))
273
274 (defun rotate-with-left-child (k2)
275 (let ((k1 (aa-left k2)))
276 (setf (aa-left k2) (aa-right k1))
277 (setf (aa-right k1) k2)
278 k1))
279
280 (defun rotate-with-right-child (k1)
281 (let ((k2 (aa-right k1)))
282 (setf (aa-right k1) (aa-left k2))
283 (setf (aa-left k2) k1)
284 k2))
285
286 (defun skew (aa)
287 (if (= (aa-level (aa-left aa)) (aa-level aa))
288 (rotate-with-left-child aa)
289 aa))
290
291 (defun split (aa)
292 (when (= (aa-level (aa-right (aa-right aa)))
293 (aa-level aa))
294 (setq aa (rotate-with-right-child aa))
295 (incf (aa-level aa)))
296 aa)
297
298 (macrolet ((def (name () &body body)
299 (let ((name (symbolicate 'aa- name)))
300 `(defun ,name (item tree &key
301 (test-< #'<) (test-= #'=)
302 (node-key #'identity) (item-key #'identity))
303 (let ((.item-key. (funcall item-key item)))
304 (flet ((item-< (node)
305 (funcall test-< .item-key.
306 (funcall node-key (aa-data node))))
307 (item-= (node)
308 (funcall test-= .item-key.
309 (funcall node-key (aa-data node)))))
310 (declare (inline item-< item-=))
311 ,@body))))))
312
313 (def insert ()
314 (labels ((insert-into (aa)
315 (cond ((eq aa *null-node*)
316 (setq aa (make-aa-node :data item
317 :left *null-node*
318 :right *null-node*)))
319 ((item-= aa)
320 (return-from insert-into aa))
321 ((item-< aa)
322 (setf (aa-left aa) (insert-into (aa-left aa))))
323 (t
324 (setf (aa-right aa) (insert-into (aa-right aa)))))
325 (split (skew aa))))
326 (setf (aa-tree-root tree)
327 (insert-into (aa-tree-root tree)))))
328
329 (def delete ()
330 (let ((deleted-node *null-node*)
331 (last-node nil))
332 (labels ((remove-from (aa)
333 (unless (eq aa *null-node*)
334 (setq last-node aa)
335 (if (item-< aa)
336 (setf (aa-left aa) (remove-from (aa-left aa)))
337 (progn
338 (setq deleted-node aa)
339 (setf (aa-right aa) (remove-from (aa-right aa)))))
340 (cond ((eq aa last-node)
341 ;;
342 ;; If at the bottom of the tree, and item
343 ;; is present, delete it.
344 (when (and (not (eq deleted-node *null-node*))
345 (item-= deleted-node))
346 (setf (aa-data deleted-node) (aa-data aa))
347 (setq deleted-node *null-node*)
348 (setq aa (aa-right aa))))
349 ;;
350 ;; Otherwise not at bottom of tree; rebalance.
351 ((or (< (aa-level (aa-left aa))
352 (1- (aa-level aa)))
353 (< (aa-level (aa-right aa))
354 (1- (aa-level aa))))
355 (decf (aa-level aa))
356 (when (> (aa-level (aa-right aa)) (aa-level aa))
357 (setf (aa-level (aa-right aa)) (aa-level aa)))
358 (setq aa (skew aa))
359 (setf (aa-right aa) (skew (aa-right aa)))
360 (setf (aa-right (aa-right aa))
361 (skew (aa-right (aa-right aa))))
362 (setq aa (split aa))
363 (setf (aa-right aa) (split (aa-right aa))))))
364 aa))
365 (setf (aa-tree-root tree)
366 (remove-from (aa-tree-root tree))))))
367
368 (def find ()
369 (let ((current (aa-tree-root tree)))
370 (setf (aa-data *null-node*) item)
371 (loop
372 (cond ((eq current *null-node*)
373 (return (values nil nil)))
374 ((item-= current)
375 (return (values (aa-data current) t)))
376 ((item-< current)
377 (setq current (aa-left current)))
378 (t
379 (setq current (aa-right current))))))))
380
381
382 ;;;; Other Utilities
383
384 ;;;
385 ;;; Sort the subsequence of Vec in the interval [From To] using
386 ;;; comparison function Test. Assume each element to sort consists of
387 ;;; Element-Size array slots, and that the slot Key-Offset contains
388 ;;; the sort key.
389 ;;;
390 (defun qsort (vec &key (element-size 1) (key-offset 0)
391 (from 0) (to (- (length vec) element-size)))
392 (declare (fixnum to from element-size key-offset)
393 (type (simple-array (unsigned-byte 32) (*)) vec))
394 (labels ((rotate (i j)
395 (declare (fixnum i j))
396 (loop repeat element-size
397 for i from i and j from j do
398 (rotatef (aref vec i) (aref vec j))))
399 (key (i)
400 (aref vec (+ i key-offset)))
401 (rec-sort (from to)
402 (declare (fixnum to from))
403 (when (> to from)
404 (let* ((mid (* element-size
405 (round (+ (/ from element-size)
406 (/ to element-size))
407 2)))
408 (i from)
409 (j (+ to element-size))
410 (p (key mid)))
411 (declare (fixnum mid i j))
412 (rotate mid from)
413 (loop
414 (loop do (incf i element-size)
415 until (or (> i to)
416 (> p (key i))))
417 (loop do (decf j element-size)
418 until (or (<= j from)
419 (> (key j) p)))
420 (when (< j i) (return))
421 (rotate i j))
422 (rotate from j)
423 (rec-sort from (- j element-size))
424 (rec-sort i to)))))
425 (rec-sort from to)
426 vec))
427
428
429 ;;;; The Profiler
430
431 (deftype address ()
432 "Type used for addresses, for instance, program counters,
433 code start/end locations etc."
434 '(unsigned-byte 32))
435
436 (defconstant +unknown-address+ 0
437 "Constant representing an address that cannot be determined.")
438
439 ;;;
440 ;;; A call graph. Vertices are Node structures, edges are Call
441 ;;; structures.
442 ;;;
443 (defstruct (call-graph (:include graph)
444 (:constructor %make-call-graph)
445 (:print-function %print-call-graph))
446 ;;
447 ;; The value of *Sample-Interval* at the time the graph was created.
448 (sample-interval (required-argument) :type number)
449 ;;
450 ;; Number of samples taken.
451 (nsamples (required-argument) :type kernel:index)
452 ;;
453 ;; Sample count for samples not in any function.
454 (elsewhere-count (required-argument) :type kernel:index)
455 ;;
456 ;; A flat list of Nodes, sorted by sample count.
457 (flat-nodes () :type list))
458
459 ;;;
460 ;;; A node in a call graph, representing a function that has been
461 ;;; sampled. The edges of a node are Call structures that represent
462 ;;; functions called from a given node.
463 ;;;
464 (defstruct (node (:include vertex)
465 (:constructor %make-node)
466 (:print-function %print-node))
467 ;;
468 ;; A numeric label for the node. The most frequently called function
469 ;; gets label 1. This is just for identification purposes in the
470 ;; profiling report.
471 (index 0 :type fixnum)
472 ;;
473 ;; Start and end address of the function's code.
474 (start-pc 0 :type address)
475 (end-pc 0 :type address)
476 ;;
477 ;; The name of the function.
478 (name nil :type t)
479 ;;
480 ;; Sample count for this function.
481 (count 0 :type fixnum)
482 ;;
483 ;; Count including time spent in functions called from this one.
484 (accrued-count 0 :type fixnum)
485 ;;
486 ;; List of Nodes for functions calling this one.
487 (callers () :type list))
488
489 ;;;
490 ;;; A cycle in a call graph. The functions forming the cycle are
491 ;;; found in the Scc-Vertices slot of struct Vertex.
492 ;;;
493 (defstruct (cycle (:include node)))
494
495 ;;;
496 ;;; An edge in a call graph. Edge-Vertex is the function being
497 ;;; called.
498 ;;;
499 (defstruct (call (:include edge)
500 (:constructor make-call (vertex))
501 (:print-function %print-call))
502 ;;
503 ;; The number of times the call was sampled.
504 (count 1 :type kernel:index))
505
506 ;;;
507 ;;; Info about a function in dynamic-space. This is used to track
508 ;;; address changes of functions during GC.
509 ;;;
510 (defstruct (dyninfo (:constructor make-dyninfo (code start end)))
511 ;;
512 ;; The component this info is for.
513 (code (required-argument) :type kernel:code-component)
514 ;;
515 ;; Current start and end address of the component.
516 (start (required-argument) :type address)
517 (end (required-argument) :type address)
518 ;;
519 ;; New start address of the component, after GC.
520 (new-start 0 :type address))
521
522 (defun %print-call-graph (call-graph stream depth)
523 (declare (ignore depth))
524 (print-unreadable-object (call-graph stream :type t :identity t)
525 (format stream "~d samples" (call-graph-nsamples call-graph))))
526
527 (defun %print-node (node stream depth)
528 (declare (ignore depth))
529 (print-unreadable-object (node stream :type t :identity t)
530 (format stream "~s [~d]" (node-name node) (node-index node))))
531
532 (defun %print-call (call stream depth)
533 (declare (ignore depth))
534 (print-unreadable-object (call stream :type t :identity t)
535 (format stream "~s [~d]" (node-name (call-vertex call))
536 (node-index (call-vertex call)))))
537
538 (deftype report-type ()
539 '(member nil :flat :graph))
540
541 (defvar *sample-interval* 0.01
542 "Default number of seconds between samples.")
543 (declaim (number *sample-interval*))
544
545 (defvar *max-samples* 10000
546 "Default number of samples taken.")
547 (declaim (type kernel:index *max-samples*))
548
549 (defconstant +sample-size+ 2)
550
551 (defvar *samples* nil)
552 (declaim (type (or null (vector address)) *samples*))
553
554 (defvar *samples-index* 0)
555 (declaim (type kernel:index *samples-index*))
556
557 (defvar *profiling* nil)
558 (defvar *sampling* nil)
559 (declaim (type boolean *profiling* *sampling*))
560
561 (defvar *dynamic-space-code-info* ())
562 (declaim (type list *dynamic-space-code-info*))
563
564 (defvar *show-progress* nil)
565
566 (defvar *old-sampling* nil)
567
568 (defun turn-off-sampling ()
569 (setq *old-sampling* *sampling*)
570 (setq *sampling* nil))
571
572 (defun turn-on-sampling ()
573 (setq *sampling* *old-sampling*))
574
575 (defun show-progress (format-string &rest args)
576 (when *show-progress*
577 (apply #'format t format-string args)
578 (finish-output)))
579
580 (defun start-sampling ()
581 "Switch on statistical sampling."
582 (setq *sampling* t))
583
584 (defun stop-sampling ()
585 "Switch off statistical sampling."
586 (setq *sampling* nil))
587
588 (defmacro with-sampling ((&optional (on t)) &body body)
589 "Evaluate body with statistical sampling turned on or off."
590 `(let ((*sampling* ,on))
591 ,@body))
592
593 (defun sort-samples (&key (key :pc))
594 "Sort *Samples* using comparison Test. Key must be one of
595 :Pc or :Return-Pc for sorting by pc or return pc."
596 (declare (type (member :pc :return-pc) key))
597 (when (plusp *samples-index*)
598 (qsort *samples*
599 :from 0
600 :to (- *samples-index* +sample-size+)
601 :element-size +sample-size+
602 :key-offset (if (eq key :pc) 0 1))))
603
604 (defun record (pc)
605 (declare (type address pc))
606 (setf (aref *samples* *samples-index*) pc)
607 (incf *samples-index*))
608
609 (in-package :di)
610 #+(and sparc gencgc)
611 (ext:without-package-locks
612 (alien:def-alien-routine component-ptr-from-pc (system:system-area-pointer)
613 (pc system:system-area-pointer)))
614 #+(and sparc gencgc)
615 (ext:without-package-locks
616 (defun component-from-component-ptr (component-ptr)
617 (declare (type system:system-area-pointer component-ptr))
618 (kernel:make-lisp-obj
619 (logior (system:sap-int component-ptr)
620 vm:other-pointer-type))))
621
622 (in-package :sprof)
623
624
625 ;;;
626 ;;; SIGPROF handler. Record current PC and return address in
627 ;;; *Samples*.
628 ;;;
629 #+x86
630 (defun sigprof-handler (signal code scp)
631 (declare (ignore signal code) (type system-area-pointer scp))
632 (when (and *sampling*
633 (< *samples-index* (length *samples*)))
634 (with-alien ((scp (* sigcontext) :local scp))
635 (locally (declare (optimize (inhibit-warnings 2)))
636 (let* ((pc-ptr (vm:sigcontext-program-counter scp))
637 (fp (vm:sigcontext-register scp #.vm::cfp-offset)))
638 (multiple-value-bind (ra-ptr up-fp-ptr)
639 (di::x86-call-context (int-sap fp))
640 (declare (ignore up-fp-ptr))
641 (record (sap-int pc-ptr))
642 (record (if ra-ptr (sap-int ra-ptr) +unknown-address+))))))))
643
644 #+sparc
645 (defun sigprof-handler (signal code scp)
646 (declare (ignore signal code) (type system-area-pointer scp))
647 (when (and *sampling*
648 (< *samples-index* (length *samples*)))
649 (with-alien ((scp (* sigcontext) :local scp))
650 (locally (declare (optimize (inhibit-warnings 2)))
651 (let* ((pc-ptr (vm:sigcontext-program-counter scp))
652 (fp (int-sap (vm:sigcontext-register scp #.vm::cfp-offset)))
653 (return-pc (sap-ref-32 fp (- (* (1+ vm::lra-save-offset)
654 vm::word-bytes)))))
655 (record (sap-int pc-ptr))
656 (record return-pc))))))
657
658 #-(or x86 sparc)
659 (defun sigprof-handler (signal code scp)
660 (declare (ignore signal code scp))
661 (error "Implement me."))
662
663 ;;;
664 ;;; Map function Fn over code objects in dynamic-space. Fn is called
665 ;;; with two arguments, the object and its size in bytes.
666 ;;;
667 (defun map-dynamic-space-code (fn)
668 (flet ((call-if-code (obj obj-type size)
669 (declare (ignore obj-type))
670 (when (kernel:code-component-p obj)
671 (funcall fn obj size))))
672 (vm::map-allocated-objects #'call-if-code :dynamic)))
673
674 ;;;
675 ;;; Return the start address of Code.
676 ;;;
677 (defun code-start (code)
678 (declare (type kernel:code-component code))
679 (sap-int (kernel:code-instructions code)))
680
681 ;;;
682 ;;; Return start and end address of Code as multiple values.
683 ;;;
684 (defun code-bounds (code)
685 (declare (type kernel:code-component code))
686 (let* ((start (code-start code))
687 (end (+ start (kernel:%code-code-size code))))
688 (values start end)))
689
690 ;;;
691 ;;; Record the addresses of dynamic-space code objects in
692 ;;; *Dynamic-Space-Code-Info*. Call this with GC disabled.
693 ;;;
694 (defun record-dyninfo ()
695 (flet ((record-address (code size)
696 (declare (ignore size))
697 (multiple-value-bind (start end)
698 (code-bounds code)
699 (push (make-dyninfo code start end)
700 *dynamic-space-code-info*))))
701 (map-dynamic-space-code #'record-address)))
702
703 ;;;
704 ;;; Adjust pcs or return-pcs in *Samples* for address changes of
705 ;;; dynamic-space code objects. Key :Pc means adjust pcs.
706 ;;;
707 (defun adjust-samples (key)
708 (declare (type (member :pc :return-pc) key))
709 (sort-samples :key key)
710 (let ((sidx 0)
711 (offset (if (eq key :pc) 0 1)))
712 (declare (type kernel:index sidx))
713 (dolist (info *dynamic-space-code-info*)
714 (unless (= (dyninfo-new-start info) (dyninfo-start info))
715 (let ((pos (do ((i sidx (+ i +sample-size+)))
716 ((= i *samples-index*) nil)
717 (declare (type kernel:index i))
718 (when (<= (dyninfo-start info)
719 (aref *samples* (+ i offset))
720 (dyninfo-end info))
721 (return i)))))
722 (when pos
723 (setq sidx pos)
724 (loop with delta = (- (dyninfo-new-start info)
725 (dyninfo-start info))
726 for j from sidx below *samples-index* by +sample-size+
727 as pc = (aref *samples* (+ j offset))
728 while (<= (dyninfo-start info) pc (dyninfo-end info)) do
729 (incf (aref *samples* (+ j offset)) delta)
730 (incf sidx +sample-size+))))))))
731
732 ;;;
733 ;;; This runs from *After-Gc-Hooks*. Adjust *Samples* for address
734 ;;; changes of dynamic-space code objects.
735 ;;;
736 (defun adjust-samples-for-address-changes ()
737 (without-gcing
738 (setq *dynamic-space-code-info*
739 (sort *dynamic-space-code-info* #'> :key #'dyninfo-start))
740 (dolist (info *dynamic-space-code-info*)
741 (setf (dyninfo-new-start info)
742 (code-start (dyninfo-code info))))
743 (adjust-samples :pc)
744 (adjust-samples :return-pc)
745 (dolist (info *dynamic-space-code-info*)
746 (let ((size (- (dyninfo-end info) (dyninfo-start info))))
747 (setf (dyninfo-start info) (dyninfo-new-start info))
748 (setf (dyninfo-end info) (+ (dyninfo-new-start info) size))))
749 (turn-on-sampling)))
750
751 (defmacro with-profiling ((&key (sample-interval '*sample-interval*)
752 (max-samples '*max-samples*)
753 (reset nil)
754 show-progress
755 (report nil report-p))
756 &body body)
757 "Repeatedly evaluate Body with statistical profiling turned on.
758 The following keyword args are recognized:
759
760 :Sample-Interval <seconds>
761 Take a sample every <seconds> seconds. Default is
762 *Sample-Interval*.
763
764 :Max-Samples <max>
765 Repeat evaluating body until <max> samples are taken.
766 Default is *Max-Samples*.
767
768 :Report <type>
769 If specified, call Report with :Type <type> at the end.
770
771 :Reset <bool>
772 It true, call Reset at the beginning."
773 (declare (type report-type report))
774 `(let ((*sample-interval* ,sample-interval)
775 (*max-samples* ,max-samples))
776 ,@(when reset '((reset)))
777 (start-profiling)
778 (loop
779 (when (>= *samples-index* (length *samples*))
780 (return))
781 ,@(when show-progress
782 `((format t "~&===> ~d of ~d samples taken.~%"
783 (/ *samples-index* +sample-size+)
784 *max-samples*)))
785 (let ((.last-index. *samples-index*))
786 ,@body
787 (when (= .last-index. *samples-index*)
788 (warn "No sampling progress; possibly a profiler bug.")
789 (return))))
790 (stop-profiling)
791 ,@(when report-p `((report :type ,report)))))
792
793 (defun start-profiling (&key (max-samples *max-samples*)
794 (sample-interval *sample-interval*)
795 (sampling t))
796 "Start profiling statistically if not already profiling.
797 The following keyword args are recognized:
798
799 :Sample-Interval <seconds>
800 Take a sample every <seconds> seconds. Default is
801 *Sample-Interval*.
802
803 :Max-Samples <max>
804 Maximum number of samples. Default is *Max-Samples*.
805
806 :Sampling <bool>
807 If true, the default, start sampling right away.
808 If false, Start-Sampling can be used to turn sampling on."
809 (unless *profiling*
810 (multiple-value-bind (secs usecs)
811 (multiple-value-bind (secs rest)
812 (truncate sample-interval)
813 (values secs (truncate (* rest 1000000))))
814 (setq *samples* (make-array (* max-samples +sample-size+)
815 :element-type 'address))
816 (setq *samples-index* 0)
817 (setq *sampling* sampling)
818 (pushnew 'turn-off-sampling *before-gc-hooks*)
819 (pushnew 'adjust-samples-for-address-changes *after-gc-hooks*)
820 (sys:without-gcing
821 (record-dyninfo))
822 (enable-interrupt :sigprof #'sigprof-handler)
823 (unix-setitimer :profile secs usecs secs usecs)
824 (setq *profiling* t)))
825 (values))
826
827 (defun stop-profiling ()
828 "Stop profiling if profiling."
829 (when *profiling*
830 (setq *after-gc-hooks*
831 (delete 'adjust-samples-for-address-changes *after-gc-hooks*))
832 (unix-setitimer :profile 0 0 0 0)
833 (enable-interrupt :sigprof :default)
834 (setq *sampling* nil)
835 (setq *profiling* nil))
836 (values))
837
838 (defun reset ()
839 "Reset the profiler."
840 (stop-profiling)
841 (setq *sampling* nil)
842 (setq *dynamic-space-code-info* ())
843 (setq *samples* nil)
844 (setq *samples-index* 0)
845 (values))
846
847 ;;;
848 ;;; Make a Node for debug-info Info.
849 ;;;
850 (defun make-node (info)
851 (typecase info
852 (kernel::code-component
853 (multiple-value-bind (start end)
854 (code-bounds info)
855 (%make-node :name (or (disassem::find-assembler-routine start)
856 (format nil "~a" info))
857 :start-pc start :end-pc end)))
858 (di::compiled-debug-function
859 (let* ((name (di::debug-function-name info))
860 (cdf (di::compiled-debug-function-compiler-debug-fun info))
861 (start-offset (c::compiled-debug-function-start-pc cdf))
862 (end-offset (c::compiled-debug-function-elsewhere-pc cdf))
863 (component (di::compiled-debug-function-component info))
864 (start-pc (code-start component)))
865 (%make-node :name name
866 :start-pc (+ start-pc start-offset)
867 :end-pc (+ start-pc end-offset))))
868 (t
869 (%make-node :name (di::debug-function-name info)))))
870
871 ;;;
872 ;;; Return something serving as debug info for address PC. If we can
873 ;;; get something from Di:Debug-Function-From-Pc, return that.
874 ;;; Otherwise, if we can determine a code component, return that.
875 ;;; Otherwise return nil.
876 ;;;
877 (defun debug-info (pc)
878 (declare (type address pc))
879 (let ((ptr (di::component-ptr-from-pc (int-sap pc))))
880 (unless (sap= ptr (int-sap 0))
881 (let* ((code (di::component-from-component-ptr ptr))
882 (code-header-len (* (kernel:get-header-data code)
883 vm:word-bytes))
884 (pc-offset (- pc
885 (- (kernel:get-lisp-obj-address code)
886 vm:other-pointer-type)
887 code-header-len))
888 (df (ignore-errors (di::debug-function-from-pc code pc-offset))))
889 (or df code)))))
890
891 ;;;
892 ;;; One function can have more than one Compiled-Debug-Function with
893 ;;; the same name. Reduce the number of calls to Debug-Info by first
894 ;;; looking for a given PC in a red-black tree. If not found in the
895 ;;; tree, get debug info, and look for a node in a hash-table by
896 ;;; function name. If not found in the hash-table, make a new node.
897 ;;;
898
899 (defvar *node-tree*)
900 (defvar *name->node*)
901
902 (defmacro with-lookup-tables (() &body body)
903 `(let ((*node-tree* (make-aa-tree))
904 (*name->node* (make-hash-table :test 'equal)))
905 ,@body))
906
907 (defun tree-find (item)
908 (flet ((pc/node-= (pc node)
909 (<= (node-start-pc node) pc (node-end-pc node)))
910 (pc/node-< (pc node)
911 (< pc (node-start-pc node))))
912 (aa-find item *node-tree* :test-= #'pc/node-= :test-< #'pc/node-<)))
913
914 (defun tree-insert (item)
915 (flet ((node/node-= (x y)
916 (<= (node-start-pc y) (node-start-pc x) (node-end-pc y)))
917 (node/node-< (x y)
918 (< (node-start-pc x) (node-start-pc y))))
919 (aa-insert item *node-tree* :test-= #'node/node-= :test-< #'node/node-<)))
920
921 ;;;
922 ;;; Find or make a new node for address PC. Value is the node
923 ;;; found or made; nil if not enough information exists to make a node
924 ;;; for PC.
925 ;;;
926 (defun lookup-node (pc)
927 (declare (type address pc))
928 (or (tree-find pc)
929 (let ((info (debug-info pc)))
930 (when info
931 (let* ((new (make-node info))
932 (found (gethash (node-name new) *name->node*)))
933 (cond (found
934 (setf (node-start-pc found)
935 (min (node-start-pc found) (node-start-pc new)))
936 (setf (node-end-pc found)
937 (max (node-end-pc found) (node-end-pc new)))
938 found)
939 (t
940 (setf (gethash (node-name new) *name->node*) new)
941 (tree-insert new)
942 new)))))))
943
944 ;;;
945 ;;; Return a list of all nodes created by Lookup-Node.
946 ;;;
947 (defun collect-nodes ()
948 (loop for node being the hash-values of *name->node*
949 collect node))
950
951 ;;;
952 ;;; Return true if Return-Pc is "plausible" (see also the large
953 ;;; comment at the start of this file). Caller and Callee are nodes
954 ;;; describing the calling and called function. Pc is the current
955 ;;; program counter.
956 ;;;
957 #+x86
958 (defun plausible-ra-p (caller return-pc pc)
959 (declare (type node caller) (type address return-pc pc))
960 (flet ((call-instruction-p (address)
961 (let ((inst (sap-ref-8 (int-sap address) 0)))
962 (or (= inst #xe8) (= inst #xff)))))
963 (and (not (call-instruction-p pc))
964 (let ((start-pc (node-start-pc caller)))
965 (or (and (>= (- return-pc 3) start-pc)
966 (call-instruction-p (- return-pc 3))
967 (and (>= (- return-pc 5) start-pc)
968 (call-instruction-p (- return-pc 5)))))))))
969
970 #-x86
971 (defun plausible-ra-p (caller return-pc pc)
972 (declare (ignore caller return-pc callee pc))
973 t)
974
975 (defvar *check-plausible-return-pc-p* nil
976 "If true, try to weed out samples that look implausible.")
977
978 ;;;
979 ;;; Value is a Call-Graph for the current contents of *Samples*.
980 ;;;
981 (defun make-call-graph-1 ()
982 (let ((elsewhere-count 0))
983 (with-lookup-tables ()
984 (loop for i below *samples-index* by +sample-size+
985 as pc = (aref *samples* i)
986 as return-pc = (aref *samples* (1+ i))
987 as callee = (lookup-node pc)
988 as caller =
989 (when (and callee (/= return-pc +unknown-address+))
990 (let ((caller (lookup-node return-pc)))
991 (when (and caller
992 (or (not *check-plausible-return-pc-p*)
993 (plausible-ra-p caller return-pc pc)))
994 caller)))
995 when (and *show-progress* (plusp i)) do
996 (cond ((zerop (mod i 1000))
997 (show-progress "~d" i))
998 ((zerop (mod i 100))
999 (show-progress ".")))
1000 if callee do
1001 (incf (node-count callee))
1002 else do
1003 (incf elsewhere-count)
1004 when (and callee caller) do
1005 (let ((call (find callee (node-edges caller)
1006 :key #'call-vertex)))
1007 (pushnew caller (node-callers callee))
1008 (if call
1009 (incf (call-count call))
1010 (push (make-call callee) (node-edges caller)))))
1011 (let ((sorted-nodes (sort (collect-nodes) #'> :key #'node-count)))
1012 (loop for node in sorted-nodes and i from 1 do
1013 (setf (node-index node) i))
1014 (%make-call-graph :nsamples (/ *samples-index* +sample-size+)
1015 :sample-interval *sample-interval*
1016 :elsewhere-count elsewhere-count
1017 :vertices sorted-nodes)))))
1018
1019 ;;;
1020 ;;; Reduce Call-Graph to a dag, creating Cycle structures for call
1021 ;;; cycles.
1022 ;;;
1023 (defun reduce-call-graph (call-graph)
1024 (let ((cycle-no 0))
1025 (flet ((make-one-cycle (vertices edges)
1026 (let* ((name (format nil "<Cycle ~d>" (incf cycle-no)))
1027 (count (loop for v in vertices sum (node-count v))))
1028 (make-cycle :name name
1029 :index cycle-no
1030 :count count
1031 :scc-vertices vertices
1032 :edges edges))))
1033 (reduce-graph call-graph #'make-one-cycle))))
1034
1035 ;;;
1036 ;;; For all nodes in Call-Graph, compute times including the time
1037 ;;; spent in functions called from them. Note that the call-graph
1038 ;;; vertices are in reverse topological order, children first, so we
1039 ;;; will have computed accrued counts of called functions before they
1040 ;;; are used to compute accrued counts for callers.
1041 ;;;
1042 (defun compute-accrued-counts (call-graph)
1043 (do-vertices (from call-graph)
1044 (setf (node-accrued-count from) (node-count from))
1045 (do-edges (call to from)
1046 (incf (node-accrued-count from)
1047 (round (* (/ (call-count call) (node-count to))
1048 (node-accrued-count to)))))))
1049
1050 ;;;
1051 ;;; Return a Call-Graph structure for the current contents of
1052 ;;; *Samples*. The result contain a list of nodes sorted by self-time
1053 ;;; in the Flat-Nodes slot, and a dag in Vertices, with call cycles
1054 ;;; reduced to Cycle structures.
1055 ;;;
1056 (defun make-call-graph ()
1057 (stop-profiling)
1058 (show-progress "~&Computing call graph ")
1059 (let ((call-graph (without-gcing (make-call-graph-1))))
1060 (setf (call-graph-flat-nodes call-graph)
1061 (copy-list (graph-vertices call-graph)))
1062 (show-progress "~&Finding cycles")
1063 (reduce-call-graph call-graph)
1064 (show-progress "~&Propagating counts")
1065 (compute-accrued-counts call-graph)
1066 call-graph))
1067
1068
1069 ;;;; Reporting
1070
1071 (defun print-separator (&key (length 72) (char #\-))
1072 (format t "~&~V,,,V<~>~%" length char))
1073
1074 (defun samples-percent (call-graph count)
1075 (* 100.0 (/ count (call-graph-nsamples call-graph))))
1076
1077 (defun print-call-graph-header (call-graph)
1078 (let ((nsamples (call-graph-nsamples call-graph))
1079 (interval (call-graph-sample-interval call-graph))
1080 (ncycles (loop for v in (graph-vertices call-graph)
1081 count (scc-p v))))
1082 (format t "~2&Number of samples: ~d~%~
1083 Sample interval: ~f seconds~%~
1084 Total sampling time: ~f seconds~%~
1085 Number of cycles: ~d~2%"
1086 nsamples
1087 interval
1088 (* nsamples interval)
1089 ncycles)))
1090
1091 (defun print-flat (call-graph &key (stream *standard-output*) max
1092 min-percent (print-header t))
1093 (let ((*standard-output* stream)
1094 (*print-pretty* nil)
1095 (total-count 0)
1096 (total-percent 0)
1097 (min-count (if min-percent
1098 (round (* (/ min-percent 100.0)
1099 (call-graph-nsamples call-graph)))
1100 0)))
1101 (when print-header
1102 (print-call-graph-header call-graph))
1103 (format t "~& Self Total~%")
1104 (format t "~& Nr Count % Count % Function~%")
1105 (print-separator)
1106 (let ((elsewhere-count (call-graph-elsewhere-count call-graph))
1107 (i 0))
1108 (dolist (node (call-graph-flat-nodes call-graph))
1109 (when (or (and max (> (incf i) max))
1110 (< (node-count node) min-count))
1111 (return))
1112 (let* ((count (node-count node))
1113 (percent (samples-percent call-graph count)))
1114 (incf total-count count)
1115 (incf total-percent percent)
1116 (format t "~&~4d ~6d ~5,1f ~6d ~5,1f ~s~%"
1117 (node-index node)
1118 count
1119 percent
1120 total-count
1121 total-percent
1122 (node-name node))))
1123 (print-separator)
1124 (format t "~& ~6d ~5,1f elsewhere~%"
1125 elsewhere-count
1126 (samples-percent call-graph elsewhere-count)))))
1127
1128 (defun print-cycles (call-graph)
1129 (when (some #'cycle-p (graph-vertices call-graph))
1130 (format t "~& Cycle~%")
1131 (format t "~& Count % Parts~%")
1132 (do-vertices (node call-graph)
1133 (when (cycle-p node)
1134 (flet ((print (indent index count percent name)
1135 (format t "~&~6d ~5,1f ~11@t ~V@t ~s [~d]~%"
1136 count percent indent name index)))
1137 (print-separator)
1138 (format t "~&~6d ~5,1f ~a...~%"
1139 (node-count node)
1140 (samples-percent call-graph (cycle-count node))
1141 (node-name node))
1142 (dolist (v (vertex-scc-vertices node))
1143 (print 4 (node-index v) (node-count v)
1144 (samples-percent call-graph (node-count v))
1145 (node-name v))))))
1146 (print-separator)
1147 (format t "~2%")))
1148
1149 (defun print-graph (call-graph &key (stream *standard-output*)
1150 max min-percent)
1151 (let ((*standard-output* stream)
1152 (*print-pretty* nil))
1153 (print-call-graph-header call-graph)
1154 (print-cycles call-graph)
1155 (flet ((find-call (from to)
1156 (find to (node-edges from) :key #'call-vertex))
1157 (print (indent index count percent name)
1158 (format t "~&~6d ~5,1f ~11@t ~V@t ~s [~d]~%"
1159 count percent indent name index)))
1160 (format t "~& Callers~%")
1161 (format t "~& Cumul. Function~%")
1162 (format t "~& Count % Count % Callees~%")
1163 (do-vertices (node call-graph)
1164 (print-separator)
1165 ;;
1166 ;; Print caller information.
1167 (dolist (caller (node-callers node))
1168 (let ((call (find-call caller node)))
1169 (print 4 (node-index caller)
1170 (call-count call)
1171 (samples-percent call-graph (call-count call))
1172 (node-name caller))))
1173 ;;
1174 ;; Print the node itself.
1175 (format t "~&~6d ~5,1f ~6d ~5,1f ~s [~d]~%"
1176 (node-count node)
1177 (samples-percent call-graph (node-count node))
1178 (node-accrued-count node)
1179 (samples-percent call-graph (node-accrued-count node))
1180 (node-name node)
1181 (node-index node))
1182 ;;
1183 ;; Print callees.
1184 (do-edges (call called node)
1185 (print 4 (node-index called)
1186 (call-count call)
1187 (samples-percent call-graph (call-count call))
1188 (node-name called))))
1189 (print-separator)
1190 (format t "~2%")
1191 (print-flat call-graph :stream stream :max max
1192 :min-percent min-percent :print-header nil))))
1193
1194 (defun report (&key (type :graph) max min-percent call-graph
1195 (stream *standard-output*) ((:show-progress *show-progress*)))
1196 "Report statistical profiling results. The following keyword
1197 args are recognized:
1198
1199 :Type <type>
1200 Specifies the type of report to generate. If :FLAT, show
1201 flat report, if :GRAPH show a call graph and a flat report.
1202 If nil, don't print out a report.
1203
1204 :Stream <stream>
1205 Specify a stream to print the report on. Default is
1206 *Standard-Output*.
1207
1208 :Max <max>
1209 Don't show more than <max> entries in the flat report.
1210
1211 :Min-Percent <min-percent>
1212 Don't show functions taking less than <min-percent> of the
1213 total time in the flat report.
1214
1215 :Show-Progress <bool>
1216 If true, print progress messages while generating the call graph.
1217
1218 :Call-Graph <graph>
1219 Print a report from <graph> instead of the latest profiling
1220 results.
1221
1222 Value of this function is a Call-Graph object representing the
1223 resulting call-graph."
1224 (declare (type report-type type))
1225 (let ((graph (or call-graph (make-call-graph))))
1226 (ecase type
1227 (:flat
1228 (print-flat graph :stream stream :max max :min-percent min-percent))
1229 (:graph
1230 (print-graph graph :stream stream :max max :min-percent min-percent))
1231 ((nil)))
1232 graph))
1233
1234 ;;;; Hook the profiler to the disassembler to provide annotations
1235 ;;;; showing how often each instruction was sampled.
1236 (defun add-disassembly-profile-note (chunk stream dstate)
1237 (declare (ignore chunk stream))
1238 (unless (zerop *samples-index*)
1239 (let* ((location
1240 (+ (disassem::seg-virtual-location
1241 (disassem:dstate-segment dstate))
1242 (disassem::dstate-cur-offs dstate)))
1243 (samples (loop for x from 0 below *samples-index* by +sample-size+
1244 summing (if (= (aref *samples* x) location)
1245 1
1246 0))))
1247 (unless (zerop samples)
1248 (disassem::note (format nil "~A/~A samples"
1249 samples (/ *samples-index* +sample-size+))
1250 dstate)))))
1251
1252
1253 (in-package :disassem)
1254
1255 ;; This hooks the profiler results into the disassembler. This is a
1256 ;; copy of map-segment-instructions from disassem.lisp.
1257 (ext:without-package-locks
1258 (defun map-segment-instructions (function segment dstate &optional stream)
1259 "Iterate through the instructions in SEGMENT, calling FUNCTION
1260 for each instruction, with arguments of CHUNK, STREAM, and DSTATE."
1261 (declare (type function function)
1262 (type segment segment)
1263 (type disassem-state dstate)
1264 (type (or null stream) stream))
1265
1266 (let ((ispace (get-inst-space (dstate-params dstate)))
1267 (prefix-p nil)) ; just processed a prefix inst
1268
1269 (rewind-current-segment dstate segment)
1270
1271 (loop
1272 (when (>= (dstate-cur-offs dstate)
1273 (seg-length (dstate-segment dstate)))
1274 ;; done!
1275 (return))
1276
1277 (setf (dstate-next-offs dstate) (dstate-cur-offs dstate))
1278
1279 (do-offs-hooks t stream dstate)
1280 (unless (or prefix-p (null stream))
1281 (print-current-address stream dstate))
1282 (do-offs-hooks nil stream dstate)
1283
1284 (unless (> (dstate-next-offs dstate) (dstate-cur-offs dstate))
1285 (system:without-gcing
1286 (setf (dstate-segment-sap dstate) (funcall (seg-sap-maker segment)))
1287
1288 (let ((chunk
1289 (sap-ref-dchunk (dstate-segment-sap dstate)
1290 (dstate-cur-offs dstate)
1291 (dstate-byte-order dstate))))
1292
1293 (let ((fun-prefix-p (do-fun-hooks chunk stream dstate)))
1294 (if (> (dstate-next-offs dstate) (dstate-cur-offs dstate))
1295 (setf prefix-p fun-prefix-p)
1296 (let ((inst (find-inst chunk ispace)))
1297 (sprof::add-disassembly-profile-note chunk stream dstate)
1298 (cond ((null inst)
1299 (handle-bogus-instruction stream dstate))
1300 (t
1301 (setf (dstate-next-offs dstate)
1302 (+ (dstate-cur-offs dstate)
1303 (inst-length inst)))
1304
1305 (let ((prefilter (inst-prefilter inst))
1306 (control (inst-control inst)))
1307 (when prefilter
1308 (funcall prefilter chunk dstate))
1309
1310 (funcall function chunk inst)
1311
1312 (setf prefix-p (null (inst-printer inst)))
1313
1314 (when control
1315 (funcall control chunk inst stream dstate)))))))))))
1316
1317 (setf (dstate-cur-offs dstate) (dstate-next-offs dstate))
1318
1319 (unless (null stream)
1320 (unless prefix-p
1321 (print-notes-and-newline stream dstate))
1322 (setf (dstate-output-state dstate) nil))))))
1323 ;;;; Silly Examples
1324
1325 (in-package "SPROF")
1326 (defun test-0 (n &optional (depth 0))
1327 (declare (optimize (debug 3)))
1328 (when (< depth n)
1329 (dotimes (i n)
1330 (test-0 n (1+ depth))
1331 (test-0 n (1+ depth)))))
1332
1333 (defun test (n)
1334 (sprof:with-profiling (:reset t :max-samples 1000 :report :graph)
1335 (test-0 n)))
1336
1337 (defun test2 ()
1338 (reset)
1339 (let ((*gc-verbose* nil))
1340 (with-profiling (:show-progress t)
1341 (compile-file "sprof" :output-file "/tmp/foo.fasl"
1342 :verbose nil
1343 :print nil :progress nil))))
1344
1345 (provide "SPROF")
1346 ;;; End of file.

  ViewVC Help
Powered by ViewVC 1.1.5