remove asdf-install contrib
[sbcl.git] / contrib / sb-sprof / sb-sprof.lisp
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.
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.
84 ;;;
85 ;;; Random ideas for implementation:
86 ;;;
87 ;;; * Space profiler.  Sample when new pages are allocated instead of
88 ;;; at SIGPROF.
89 ;;;
90 ;;; * Record a configurable number of callers up the stack.  That
91 ;;; could give a more complete graph when there are many small
92 ;;; functions.
93 ;;;
94 ;;; * Print help strings for reports, include hints to the problem
95 ;;; explained above.
96 ;;;
97 ;;; * Make flat report the default since call-graph isn't that
98 ;;; reliable?
99
100 (defpackage #:sb-sprof
101   (:use #:cl #:sb-ext #:sb-unix #:sb-alien #:sb-sys :sb-int)
102   (:export #:*sample-interval* #:*max-samples* #:*alloc-interval*
103            #:*report-sort-by* #:*report-sort-order*
104            #:start-sampling #:stop-sampling #:with-sampling
105            #:with-profiling #:start-profiling #:stop-profiling
106            #:profile-call-counts #:unprofile-call-counts
107            #:reset #:report))
108
109 (in-package #:sb-sprof)
110
111 \f
112 ;;;; Graph Utilities
113
114 (defstruct (vertex (:constructor make-vertex)
115                    (:constructor make-scc (scc-vertices edges)))
116   (visited     nil :type boolean)
117   (root        nil :type (or null vertex))
118   (dfn           0 :type fixnum)
119   (edges        () :type list)
120   (scc-vertices () :type list))
121
122 (defstruct edge
123   (vertex (sb-impl::missing-arg) :type vertex))
124
125 (defstruct graph
126   (vertices () :type list))
127
128 (declaim (inline scc-p))
129 (defun scc-p (vertex)
130   (not (null (vertex-scc-vertices vertex))))
131
132 (defmacro do-vertices ((vertex graph) &body body)
133   `(dolist (,vertex (graph-vertices ,graph))
134      ,@body))
135
136 (defmacro do-edges ((edge edge-to vertex) &body body)
137   `(dolist (,edge (vertex-edges ,vertex))
138      (let ((,edge-to (edge-vertex ,edge)))
139        ,@body)))
140
141 (defun self-cycle-p (vertex)
142   (do-edges (e to vertex)
143     (when (eq to vertex)
144       (return t))))
145
146 (defun map-vertices (fn vertices)
147   (dolist (v vertices)
148     (setf (vertex-visited v) nil))
149   (dolist (v vertices)
150     (unless (vertex-visited v)
151       (funcall fn v))))
152
153 ;;; Eeko Nuutila, Eljas Soisalon-Soininen, around 1992.  Improves on
154 ;;; Tarjan's original algorithm by not using the stack when processing
155 ;;; trivial components.  Trivial components should appear frequently
156 ;;; in a call-graph such as ours, I think.  Same complexity O(V+E) as
157 ;;; Tarjan.
158 (defun strong-components (vertices)
159   (let ((in-component (make-array (length vertices)
160                                   :element-type 'boolean
161                                   :initial-element nil))
162         (stack ())
163         (components ())
164         (dfn -1))
165     (labels ((min-root (x y)
166                (let ((rx (vertex-root x))
167                      (ry (vertex-root y)))
168                  (if (< (vertex-dfn rx) (vertex-dfn ry))
169                      rx
170                      ry)))
171              (in-component (v)
172                (aref in-component (vertex-dfn v)))
173              ((setf in-component) (in v)
174                (setf (aref in-component (vertex-dfn v)) in))
175              (vertex-> (x y)
176                (> (vertex-dfn x) (vertex-dfn y)))
177              (visit (v)
178                (setf (vertex-dfn v) (incf dfn)
179                      (in-component v) nil
180                      (vertex-root v) v
181                      (vertex-visited v) t)
182                (do-edges (e w v)
183                  (unless (vertex-visited w)
184                    (visit w))
185                  (unless (in-component w)
186                    (setf (vertex-root v) (min-root v w))))
187                (if (eq v (vertex-root v))
188                    (loop while (and stack (vertex-> (car stack) v))
189                          as w = (pop stack)
190                          collect w into this-component
191                          do (setf (in-component w) t)
192                          finally
193                            (setf (in-component v) t)
194                            (push (cons v this-component) components))
195                    (push v stack))))
196       (map-vertices #'visit vertices)
197       components)))
198
199 ;;; Given a dag as a list of vertices, return the list sorted
200 ;;; topologically, children first.
201 (defun topological-sort (dag)
202   (let ((sorted ())
203         (dfn -1))
204     (labels ((rec-sort (v)
205                (setf (vertex-visited v) t)
206                (setf (vertex-dfn v) (incf dfn))
207                (dolist (e (vertex-edges v))
208                  (unless (vertex-visited (edge-vertex e))
209                    (rec-sort (edge-vertex e))))
210                (push v sorted)))
211       (map-vertices #'rec-sort dag)
212       (nreverse sorted))))
213
214 ;;; Reduce graph G to a dag by coalescing strongly connected components
215 ;;; into vertices.  Sort the result topologically.
216 (defun reduce-graph (graph &optional (scc-constructor #'make-scc))
217   (sb-int:collect ((sccs) (trivial))
218     (dolist (c (strong-components (graph-vertices graph)))
219       (if (or (cdr c) (self-cycle-p (car c)))
220           (sb-int:collect ((outgoing))
221             (dolist (v c)
222               (do-edges (e w v)
223                 (unless (member w c)
224                   (outgoing e))))
225             (sccs (funcall scc-constructor c (outgoing))))
226           (trivial (car c))))
227     (dolist (scc (sccs))
228       (dolist (v (trivial))
229         (do-edges (e w v)
230           (when (member w (vertex-scc-vertices scc))
231             (setf (edge-vertex e) scc)))))
232     (setf (graph-vertices graph)
233           (topological-sort (nconc (sccs) (trivial))))))
234 \f
235 ;;;; The Profiler
236
237 (deftype address ()
238   "Type used for addresses, for instance, program counters,
239    code start/end locations etc."
240   '(unsigned-byte #.sb-vm::n-machine-word-bits))
241
242 (defconstant +unknown-address+ 0
243   "Constant representing an address that cannot be determined.")
244
245 ;;; A call graph.  Vertices are NODE structures, edges are CALL
246 ;;; structures.
247 (defstruct (call-graph (:include graph)
248                        (:constructor %make-call-graph))
249   ;; the value of *SAMPLE-INTERVAL* or *ALLOC-INTERVAL* at the time
250   ;; the graph was created (depending on the current allocation mode)
251   (sample-interval (sb-impl::missing-arg) :type number)
252   ;; the sampling-mode that was used for the profiling run
253   (sampling-mode (sb-impl::missing-arg) :type (member :cpu :alloc :time))
254   ;; number of samples taken
255   (nsamples (sb-impl::missing-arg) :type sb-int:index)
256   ;; threads that have been sampled
257   (sampled-threads nil :type list)
258   ;; sample count for samples not in any function
259   (elsewhere-count (sb-impl::missing-arg) :type sb-int:index)
260   ;; a flat list of NODEs, sorted by sample count
261   (flat-nodes () :type list))
262
263 ;;; A node in a call graph, representing a function that has been
264 ;;; sampled.  The edges of a node are CALL structures that represent
265 ;;; functions called from a given node.
266 (defstruct (node (:include vertex)
267                  (:constructor %make-node))
268   ;; A numeric label for the node.  The most frequently called function
269   ;; gets label 1.  This is just for identification purposes in the
270   ;; profiling report.
271   (index 0 :type fixnum)
272   ;; Start and end address of the function's code. Depending on the
273   ;; debug-info, this might be either as absolute addresses for things
274   ;; that won't move around in memory, or as relative offsets from
275   ;; some point for things that might move.
276   (start-pc-or-offset 0 :type address)
277   (end-pc-or-offset 0 :type address)
278   ;; the name of the function
279   (name nil :type t)
280   ;; sample count for this function
281   (count 0 :type fixnum)
282   ;; count including time spent in functions called from this one
283   (accrued-count 0 :type fixnum)
284   ;; the debug-info that this node was created from
285   (debug-info nil :type t)
286   ;; list of NODEs for functions calling this one
287   (callers () :type list)
288   ;; the call count for the function that corresponds to this node (or NIL
289   ;; if call counting wasn't enabled for this function)
290   (call-count nil :type (or null integer)))
291
292 ;;; A cycle in a call graph.  The functions forming the cycle are
293 ;;; found in the SCC-VERTICES slot of the VERTEX structure.
294 (defstruct (cycle (:include node)))
295
296 ;;; An edge in a call graph.  EDGE-VERTEX is the function being
297 ;;; called.
298 (defstruct (call (:include edge)
299                  (:constructor make-call (vertex)))
300   ;; number of times the call was sampled
301   (count 1 :type sb-int:index))
302
303 (defvar *sample-interval* 0.01
304   "Default number of seconds between samples.")
305 (declaim (type number *sample-interval*))
306
307 (defvar *alloc-interval* 4
308   "Default number of allocation region openings between samples.")
309 (declaim (type number *alloc-interval*))
310
311 (defvar *max-samples* 50000
312   "Default number of traces taken. This variable is somewhat misnamed:
313 each trace may actually consist of an arbitrary number of samples, depending
314 on the depth of the call stack.")
315 (declaim (type sb-int:index *max-samples*))
316
317 ;;; Encapsulate all the information about a sampling run
318 (defstruct (samples)
319   ;; When this vector fills up, we allocate a new one and copy over
320   ;; the old contents.
321   (vector (make-array (* *max-samples*
322                          ;; Arbitrary guess at how many samples we'll be
323                          ;; taking for each trace. The exact amount doesn't
324                          ;; matter, this is just to decrease the amount of
325                          ;; re-allocation that will need to be done.
326                          10
327                          ;; Each sample takes two cells in the vector
328                          2))
329           :type simple-vector)
330   (trace-count 0 :type sb-int:index)
331   (index 0 :type sb-int:index)
332   (mode nil :type (member :cpu :alloc :time))
333   (sample-interval (sb-int:missing-arg) :type number)
334   (alloc-interval (sb-int:missing-arg) :type number)
335   (max-depth most-positive-fixnum :type number)
336   (max-samples (sb-int:missing-arg) :type sb-int:index)
337   (sampled-threads nil :type list))
338
339 (defmethod print-object ((samples samples) stream)
340   (print-unreadable-object (samples stream :type t :identity t)
341     (let ((*print-array* nil))
342       (call-next-method))))
343
344 (defmethod print-object ((call-graph call-graph) stream)
345   (print-unreadable-object (call-graph stream :type t :identity t)
346     (format stream "~d samples" (call-graph-nsamples call-graph))))
347
348 (defmethod print-object ((node node) stream)
349   (print-unreadable-object (node stream :type t :identity t)
350     (format stream "~s [~d]" (node-name node) (node-index node))))
351
352 (defmethod print-object ((call call) stream)
353   (print-unreadable-object (call stream :type t :identity t)
354     (format stream "~s [~d]" (node-name (call-vertex call))
355             (node-index (call-vertex call)))))
356
357 (deftype report-type ()
358   '(member nil :flat :graph))
359
360 (defvar *sampling-mode* :cpu
361   "Default sampling mode. :CPU for cpu profiling, :ALLOC for allocation
362 profiling, and :TIME for wallclock profiling.")
363 (declaim (type (member :cpu :alloc :time) *sampling-mode*))
364
365 (defvar *alloc-region-size*
366   #-gencgc
367   (get-page-size)
368   #+gencgc
369   (max sb-vm:gencgc-alloc-granularity sb-vm:gencgc-card-bytes))
370 (declaim (type number *alloc-region-size*))
371
372 (defvar *samples* nil)
373 (declaim (type (or null samples) *samples*))
374
375 (defvar *profiling* nil)
376 (declaim (type (member nil :alloc :cpu :time) *profiling*))
377 (defvar *sampling* nil)
378 (declaim (type boolean *sampling*))
379
380 (defvar *show-progress* nil)
381
382 (defvar *old-sampling* nil)
383
384 ;; Call count encapsulation information
385 (defvar *encapsulations* (make-hash-table :test 'equal))
386
387 (defun turn-off-sampling ()
388   (setq *old-sampling* *sampling*)
389   (setq *sampling* nil))
390
391 (defun turn-on-sampling ()
392   (setq *sampling* *old-sampling*))
393
394 (defun show-progress (format-string &rest args)
395   (when *show-progress*
396     (apply #'format t format-string args)
397     (finish-output)))
398
399 (defun start-sampling ()
400   "Switch on statistical sampling."
401   (setq *sampling* t))
402
403 (defun stop-sampling ()
404   "Switch off statistical sampling."
405   (setq *sampling* nil))
406
407 (defmacro with-sampling ((&optional (on t)) &body body)
408   "Evaluate body with statistical sampling turned on or off."
409   `(let ((*sampling* ,on)
410          (sb-vm:*alloc-signal* sb-vm:*alloc-signal*))
411      ,@body))
412
413 ;;; Return something serving as debug info for address PC.
414 (declaim (inline debug-info))
415 (defun debug-info (pc)
416   (declare (type system-area-pointer pc)
417            (muffle-conditions compiler-note))
418   (let ((ptr (sb-di::component-ptr-from-pc pc)))
419     (cond ((sap= ptr (int-sap 0))
420            (let ((name (sap-foreign-symbol pc)))
421              (if name
422                  (values (format nil "foreign function ~a" name)
423                          (sap-int pc))
424                  (values nil (sap-int pc)))))
425           (t
426            (let* ((code (sb-di::component-from-component-ptr ptr))
427                   (code-header-len (* (sb-kernel:get-header-data code)
428                                       sb-vm:n-word-bytes))
429                   (pc-offset (- (sap-int pc)
430                                 (- (sb-kernel:get-lisp-obj-address code)
431                                    sb-vm:other-pointer-lowtag)
432                                 code-header-len))
433                   (df (sb-di::debug-fun-from-pc code pc-offset)))
434              (cond ((typep df 'sb-di::bogus-debug-fun)
435                     (values code (sap-int pc)))
436                    (df
437                     ;; The code component might be moved by the GC. Store
438                     ;; a PC offset, and reconstruct the data in
439                     ;; SAMPLE-PC-FROM-PC-OR-OFFSET.
440                     (values df pc-offset))
441                    (t
442                     (values nil 0))))))))
443
444 (defun ensure-samples-vector (samples)
445   (let ((vector (samples-vector samples))
446         (index (samples-index samples)))
447     ;; Allocate a new sample vector if the old one is full
448     (if (= (length vector) index)
449         (let ((new-vector (make-array (* 2 index))))
450           (format *trace-output* "Profiler sample vector full (~a traces / ~a samples), doubling the size~%"
451                   (samples-trace-count samples)
452                   (truncate index 2))
453           (replace new-vector vector)
454           (setf (samples-vector samples) new-vector))
455         vector)))
456
457 (declaim (inline record))
458 (defun record (samples pc)
459   (declare (type system-area-pointer pc)
460            (muffle-conditions compiler-note))
461   (multiple-value-bind (info pc-or-offset)
462       (debug-info pc)
463     (let ((vector (ensure-samples-vector samples))
464           (index (samples-index samples)))
465       (declare (type simple-vector vector))
466       ;; Allocate a new sample vector if the old one is full
467       (when (= (length vector) index)
468         (let ((new-vector (make-array (* 2 index))))
469           (format *trace-output* "Profiler sample vector full (~a traces / ~a samples), doubling the size~%"
470                   (samples-trace-count samples)
471                   (truncate index 2))
472           (replace new-vector vector)
473           (setf vector new-vector
474                 (samples-vector samples) new-vector)))
475       ;; For each sample, store the debug-info and the PC/offset into
476       ;; adjacent cells.
477       (setf (aref vector index) info
478             (aref vector (1+ index)) pc-or-offset)))
479   (incf (samples-index samples) 2))
480
481 (defun record-trace-start (samples)
482   ;; Mark the start of the trace.
483   (let ((vector (ensure-samples-vector samples)))
484     (declare (type simple-vector vector))
485     (setf (aref vector (samples-index samples))
486           'trace-start))
487   (incf (samples-index samples) 2))
488
489 ;;; List of thread currently profiled, or :ALL for all threads.
490 (defvar *profiled-threads* nil)
491 (declaim (type (or list (member :all)) *profiled-threads*))
492
493 ;;; Thread which runs the wallclock timers, if any.
494 (defvar *timer-thread* nil)
495
496 (defun profiled-threads ()
497   (let ((profiled-threads *profiled-threads*))
498     (remove *timer-thread*
499             (if (eq :all profiled-threads)
500                 (sb-thread:list-all-threads)
501                 profiled-threads))))
502
503 (defun profiled-thread-p (thread)
504   (let ((profiled-threads *profiled-threads*))
505     (or (and (eq :all profiled-threads)
506              (not (eq *timer-thread* thread)))
507         (member thread profiled-threads :test #'eq))))
508
509 #+(or x86 x86-64)
510 (progn
511   ;; Ensure that only one thread at a time will be doing profiling stuff.
512   (defvar *profiler-lock* (sb-thread:make-mutex :name "Statistical Profiler"))
513   (defvar *distribution-lock* (sb-thread:make-mutex :name "Wallclock profiling lock"))
514
515   #+sb-thread
516   (declaim (inline pthread-kill))
517   #+sb-thread
518   (define-alien-routine pthread-kill int (os-thread unsigned-long) (signal int))
519
520   ;;; A random thread will call this in response to either a timer firing,
521   ;;; This in turn will distribute the notice to those threads we are
522   ;;; interested using SIGPROF.
523   (defun thread-distribution-handler ()
524     (declare (optimize speed (space 0)))
525     #+sb-thread
526     (let ((lock *distribution-lock*))
527       ;; Don't flood the system with more interrupts if the last
528       ;; set is still being delivered.
529       (unless (sb-thread:mutex-value lock)
530         (sb-thread::with-system-mutex (lock)
531           (dolist (thread (profiled-threads))
532             ;; This may occasionally fail to deliver the signal, but that
533             ;; seems better then using kill_thread_safely with it's 1
534             ;; second backoff.
535             (let ((os-thread (sb-thread::thread-os-thread thread)))
536               (when os-thread
537                 (pthread-kill os-thread sb-unix:sigprof)))))))
538     #-sb-thread
539     (unix-kill 0 sb-unix:sigprof))
540
541   (defun sigprof-handler (signal code scp)
542     (declare (ignore signal code) (optimize speed (space 0))
543              (disable-package-locks sb-di::x86-call-context)
544              (muffle-conditions compiler-note)
545              (type system-area-pointer scp))
546     (let ((self sb-thread:*current-thread*)
547           (profiling *profiling*))
548       ;; Turn off allocation counter when it is not needed. Doing this in the
549       ;; signal handler means we don't have to worry about racing with the runtime
550       (unless (eq :alloc profiling)
551         (setf sb-vm::*alloc-signal* nil))
552       (when (and *sampling*
553                  ;; Normal SIGPROF gets practically speaking delivered to threads
554                  ;; depending on the run time they use, so we need to filter
555                  ;; out those we don't care about. For :ALLOC and :TIME profiling
556                  ;; only the interesting threads get SIGPROF in the first place.
557                  ;;
558                  ;; ...except that Darwin at least doesn't seem to work like we
559                  ;; would want it to, which makes multithreaded :CPU profiling pretty
560                  ;; pointless there -- though it may be that our mach magic is
561                  ;; partially to blame?
562                  (or (not (eq :cpu profiling)) (profiled-thread-p self)))
563         (sb-thread::with-system-mutex (*profiler-lock* :without-gcing t)
564           (let ((samples *samples*))
565             (when (and samples
566                        (< (samples-trace-count samples)
567                           (samples-max-samples samples)))
568               (with-alien ((scp (* os-context-t) :local scp))
569                 (let* ((pc-ptr (sb-vm:context-pc scp))
570                        (fp (sb-vm::context-register scp #.sb-vm::ebp-offset)))
571                   ;; foreign code might not have a useful frame
572                   ;; pointer in ebp/rbp, so make sure it looks
573                   ;; reasonable before walking the stack
574                   (unless (sb-di::control-stack-pointer-valid-p (sb-sys:int-sap fp))
575                     (record samples pc-ptr)
576                     (return-from sigprof-handler nil))
577                   (incf (samples-trace-count samples))
578                   (pushnew self (samples-sampled-threads samples))
579                   (let ((fp (int-sap fp))
580                         (ok t))
581                     (declare (type system-area-pointer fp pc-ptr))
582                     ;; FIXME: How annoying. The XC doesn't store enough
583                     ;; type information about SB-DI::X86-CALL-CONTEXT,
584                     ;; even if we declaim the ftype explicitly in
585                     ;; src/code/debug-int. And for some reason that type
586                     ;; information is needed for the inlined version to
587                     ;; be compiled without boxing the returned saps. So
588                     ;; we declare the correct ftype here manually, even
589                     ;; if the compiler should be able to deduce this
590                     ;; exact same information.
591                     (declare (ftype (function (system-area-pointer)
592                                               (values (member nil t)
593                                                       system-area-pointer
594                                                       system-area-pointer))
595                                     sb-di::x86-call-context))
596                     (record-trace-start samples)
597                     (dotimes (i (samples-max-depth samples))
598                       (record samples pc-ptr)
599                       (setf (values ok pc-ptr fp)
600                             (sb-di::x86-call-context fp))
601                       (unless ok
602                         (return))))))
603               ;; Reset thread-local allocation counter before interrupts
604               ;; are enabled.
605               (when (eq t sb-vm::*alloc-signal*)
606                 (setf sb-vm:*alloc-signal* (1- (samples-alloc-interval samples)))))))))
607     nil))
608
609 ;; FIXME: On non-x86 platforms we don't yet walk the call stack deeper
610 ;; than one level.
611 #-(or x86 x86-64)
612 (defun sigprof-handler (signal code scp)
613   (declare (ignore signal code))
614   (sb-sys:without-interrupts
615     (let ((samples *samples*))
616       (when (and *sampling*
617                  samples
618                  (< (samples-trace-count samples)
619                     (samples-max-samples samples)))
620         (sb-sys:without-gcing
621           (with-alien ((scp (* os-context-t) :local scp))
622             (locally (declare (optimize (inhibit-warnings 2)))
623               (incf (samples-trace-count samples))
624               (record-trace-start samples)
625               (let* ((pc-ptr (sb-vm:context-pc scp))
626                      (fp (sb-vm::context-register scp #.sb-vm::cfp-offset))
627                      (ra (sap-ref-word
628                           (int-sap fp)
629                           (* sb-vm::lra-save-offset sb-vm::n-word-bytes))))
630                 (record samples pc-ptr)
631                 (record samples (int-sap ra))))))))))
632
633 ;;; Return the start address of CODE.
634 (defun code-start (code)
635   (declare (type sb-kernel:code-component code))
636   (sap-int (sb-kernel:code-instructions code)))
637
638 ;;; Return start and end address of CODE as multiple values.
639 (defun code-bounds (code)
640   (declare (type sb-kernel:code-component code))
641   (let* ((start (code-start code))
642          (end (+ start (sb-kernel:%code-code-size code))))
643     (values start end)))
644
645 (defmacro with-profiling ((&key (sample-interval '*sample-interval*)
646                                 (alloc-interval '*alloc-interval*)
647                                 (max-samples '*max-samples*)
648                                 (reset nil)
649                                 (mode '*sampling-mode*)
650                                 (loop nil)
651                                 (max-depth most-positive-fixnum)
652                                 show-progress
653                                 (threads '(list sb-thread:*current-thread*))
654                                 (report nil report-p))
655                           &body body)
656   "Evaluate BODY with statistical profiling turned on. If LOOP is true,
657 loop around the BODY until a sufficient number of samples has been collected.
658 Returns the values from the last evaluation of BODY.
659
660 In multithreaded operation, only the thread in which WITH-PROFILING was
661 evaluated will be profiled by default. If you want to profile multiple
662 threads, invoke the profiler with START-PROFILING.
663
664 The following keyword args are recognized:
665
666  :SAMPLE-INTERVAL <n>
667    Take a sample every <n> seconds. Default is *SAMPLE-INTERVAL*.
668
669  :ALLOC-INTERVAL <n>
670    Take a sample every time <n> allocation regions (approximately
671    8kB) have been allocated since the last sample. Default is
672    *ALLOC-INTERVAL*.
673
674  :MODE <mode>
675    If :CPU, run the profiler in CPU profiling mode. If :ALLOC, run the
676    profiler in allocation profiling mode. If :TIME, run the profiler
677    in wallclock profiling mode.
678
679  :MAX-SAMPLES <max>
680    Repeat evaluating body until <max> samples are taken.
681    Default is *MAX-SAMPLES*.
682
683  :MAX-DEPTH <max>
684    Maximum call stack depth that the profiler should consider. Only
685    has an effect on x86 and x86-64.
686
687  :REPORT <type>
688    If specified, call REPORT with :TYPE <type> at the end.
689
690  :RESET <bool>
691    It true, call RESET at the beginning.
692
693  :THREADS <list-form>
694    Form that evaluates to the list threads to profile, or :ALL to indicate
695    that all threads should be profiled. Defaults to the current
696    thread. (Note: START-PROFILING defaults to all threads.)
697
698    :THREADS has no effect on call-counting at the moment.
699
700    On some platforms (eg. Darwin) the signals used by the profiler are
701    not properly delivered to threads in proportion to their CPU usage
702    when doing :CPU profiling. If you see empty call graphs, or are obviously
703    missing several samples from certain threads, you may be falling afoul
704    of this. In this case using :MODE :TIME is likely to work better.
705
706  :LOOP <bool>
707    If false (the default), evaluate BODY only once. If true repeatedly
708    evaluate BODY."
709   (declare (type report-type report))
710   (check-type loop boolean)
711   (with-unique-names (values last-index oops)
712     `(let* ((*sample-interval* ,sample-interval)
713             (*alloc-interval* ,alloc-interval)
714             (*sampling* nil)
715             (*sampling-mode* ,mode)
716             (*max-samples* ,max-samples))
717        ,@(when reset '((reset)))
718        (flet ((,oops ()
719                 (warn "~@<No sampling progress; run too short, sampling interval ~
720                        too long, inappropriate set of sampled thread, or possibly ~
721                        a profiler bug.~:@>")))
722          (unwind-protect
723               (progn
724                 (start-profiling :max-depth ,max-depth :threads ,threads)
725                 ,(if loop
726                      `(let (,values)
727                         (loop
728                           (when (>= (samples-trace-count *samples*)
729                                     (samples-max-samples *samples*))
730                             (return))
731                           ,@(when show-progress
732                               `((format t "~&===> ~d of ~d samples taken.~%"
733                                         (samples-trace-count *samples*)
734                                         (samples-max-samples *samples*))))
735                           (let ((,last-index, (samples-index *samples*)))
736                             (setf ,values (multiple-value-list (progn ,@body)))
737                             (when (= ,last-index (samples-index *samples*))
738                               (,oops)
739                               (return))))
740                         (values-list ,values))
741                      `(let ((,last-index (samples-index *samples*)))
742                         (multiple-value-prog1 (progn ,@body)
743                           (when (= ,last-index (samples-index *samples*))
744                             (,oops))))))
745            (stop-profiling)))
746        ,@(when report-p `((report :type ,report))))))
747
748 (defvar *timer* nil)
749
750 (defvar *old-alloc-interval* nil)
751 (defvar *old-sample-interval* nil)
752
753 (defun start-profiling (&key (max-samples *max-samples*)
754                         (mode *sampling-mode*)
755                         (sample-interval *sample-interval*)
756                         (alloc-interval *alloc-interval*)
757                         (max-depth most-positive-fixnum)
758                         (threads :all)
759                         (sampling t))
760   "Start profiling statistically in the current thread if not already profiling.
761 The following keyword args are recognized:
762
763    :SAMPLE-INTERVAL <n>
764      Take a sample every <n> seconds.  Default is *SAMPLE-INTERVAL*.
765
766    :ALLOC-INTERVAL <n>
767      Take a sample every time <n> allocation regions (approximately
768      8kB) have been allocated since the last sample. Default is
769      *ALLOC-INTERVAL*.
770
771    :MODE <mode>
772      If :CPU, run the profiler in CPU profiling mode. If :ALLOC, run
773      the profiler in allocation profiling mode. If :TIME, run the profiler
774      in wallclock profiling mode.
775
776    :MAX-SAMPLES <max>
777      Maximum number of samples.  Default is *MAX-SAMPLES*.
778
779    :MAX-DEPTH <max>
780      Maximum call stack depth that the profiler should consider. Only
781      has an effect on x86 and x86-64.
782
783    :THREADS <list>
784      List threads to profile, or :ALL to indicate that all threads should be
785      profiled. Defaults to :ALL. (Note: WITH-PROFILING defaults to the current
786      thread.)
787
788      :THREADS has no effect on call-counting at the moment.
789
790      On some platforms (eg. Darwin) the signals used by the profiler are
791      not properly delivered to threads in proportion to their CPU usage
792      when doing :CPU profiling. If you see empty call graphs, or are obviously
793      missing several samples from certain threads, you may be falling afoul
794      of this.
795
796    :SAMPLING <bool>
797      If true, the default, start sampling right away.
798      If false, START-SAMPLING can be used to turn sampling on."
799   #-gencgc
800   (when (eq mode :alloc)
801     (error "Allocation profiling is only supported for builds using the generational garbage collector."))
802   (unless *profiling*
803     (multiple-value-bind (secs usecs)
804         (multiple-value-bind (secs rest)
805             (truncate sample-interval)
806           (values secs (truncate (* rest 1000000))))
807       (setf *sampling* sampling
808             *samples* (make-samples :max-depth max-depth
809                                     :max-samples max-samples
810                                     :sample-interval sample-interval
811                                     :alloc-interval alloc-interval
812                                     :mode mode))
813       (enable-call-counting)
814       (setf *profiled-threads* threads)
815       (sb-sys:enable-interrupt sb-unix:sigprof
816                                #'sigprof-handler
817                                :synchronous t)
818       (ecase mode
819         (:alloc
820          (let ((alloc-signal (1- alloc-interval)))
821            #+sb-thread
822            (progn
823              (when (eq :all threads)
824                ;; Set the value new threads inherit.
825                (sb-thread::with-all-threads-lock
826                  (setf sb-thread::*default-alloc-signal* alloc-signal)))
827              ;; Turn on allocation profiling in existing threads.
828              (dolist (thread (profiled-threads))
829                (sb-thread::%set-symbol-value-in-thread 'sb-vm::*alloc-signal* thread alloc-signal)))
830            #-sb-thread
831            (setf sb-vm:*alloc-signal* alloc-signal)))
832         (:cpu
833          (unix-setitimer :profile secs usecs secs usecs))
834         (:time
835          #+sb-thread
836          (let ((setup (sb-thread:make-semaphore :name "Timer thread setup semaphore")))
837            (setf *timer-thread*
838                  (sb-thread:make-thread (lambda ()
839                                           (sb-thread:wait-on-semaphore setup)
840                                           (loop while (eq sb-thread:*current-thread* *timer-thread*)
841                                                 do (sleep 1.0)))
842                                         :name "SB-SPROF wallclock timer thread"))
843            (sb-thread:signal-semaphore setup))
844          #-sb-thread
845          (setf *timer-thread* nil)
846          (setf *timer* (make-timer #'thread-distribution-handler :name "SB-PROF wallclock timer"
847                                    :thread *timer-thread*))
848          (schedule-timer *timer* sample-interval :repeat-interval sample-interval)))
849       (setq *profiling* mode)))
850   (values))
851
852 (defun stop-profiling ()
853   "Stop profiling if profiling."
854   (let ((profiling *profiling*))
855     (when profiling
856       ;; Even with the timers shut down we cannot be sure that there is no
857       ;; undelivered sigprof. The handler is also responsible for turning the
858       ;; *ALLOC-SIGNAL* off in individual threads.
859       (ecase profiling
860         (:alloc
861          #+sb-thread
862          (setf sb-thread::*default-alloc-signal* nil)
863          #-sb-thread
864          (setf sb-vm:*alloc-signal* nil))
865         (:cpu
866          (unix-setitimer :profile 0 0 0 0))
867         (:time
868          (unschedule-timer *timer*)
869          (setf *timer* nil
870                *timer-thread* nil)))
871      (disable-call-counting)
872      (setf *profiling* nil
873            *sampling* nil
874            *profiled-threads* nil)))
875   (values))
876
877 (defun reset ()
878   "Reset the profiler."
879   (stop-profiling)
880   (setq *sampling* nil)
881   (setq *samples* nil)
882   (values))
883
884 ;;; Make a NODE for debug-info INFO.
885 (defun make-node (info)
886   (flet ((clean-name (name)
887            (if (and (consp name)
888                     (member (first name)
889                             '(sb-c::xep sb-c::tl-xep sb-c::&more-processor
890                               sb-c::top-level-form
891                               sb-c::&optional-processor)))
892                (second name)
893                name)))
894     (typecase info
895       (sb-kernel::code-component
896        (multiple-value-bind (start end)
897            (code-bounds info)
898          (values
899           (%make-node :name (or (sb-disassem::find-assembler-routine start)
900                                 (format nil "~a" info))
901                       :debug-info info
902                       :start-pc-or-offset start
903                       :end-pc-or-offset end)
904           info)))
905       (sb-di::compiled-debug-fun
906        (let* ((name (sb-di::debug-fun-name info))
907               (cdf (sb-di::compiled-debug-fun-compiler-debug-fun info))
908               (start-offset (sb-c::compiled-debug-fun-start-pc cdf))
909               (end-offset (sb-c::compiled-debug-fun-elsewhere-pc cdf))
910               (component (sb-di::compiled-debug-fun-component info))
911               (start-pc (code-start component)))
912          ;; Call graphs are mostly useless unless we somehow
913          ;; distinguish a gazillion different (LAMBDA ())'s.
914          (when (equal name '(lambda ()))
915            (setf name (format nil "Unknown component: #x~x" start-pc)))
916          (values (%make-node :name (clean-name name)
917                              :debug-info info
918                              :start-pc-or-offset start-offset
919                              :end-pc-or-offset end-offset)
920                  component)))
921       (sb-di::debug-fun
922        (%make-node :name (clean-name (sb-di::debug-fun-name info))
923                    :debug-info info))
924       (t
925        (%make-node :name (coerce info 'string)
926                    :debug-info info)))))
927
928 ;;; One function can have more than one COMPILED-DEBUG-FUNCTION with
929 ;;; the same name.  Reduce the number of calls to Debug-Info by first
930 ;;; looking for a given PC in a red-black tree.  If not found in the
931 ;;; tree, get debug info, and look for a node in a hash-table by
932 ;;; function name.  If not found in the hash-table, make a new node.
933
934 (defvar *name->node*)
935
936 (defmacro with-lookup-tables (() &body body)
937   `(let ((*name->node* (make-hash-table :test 'equal)))
938      ,@body))
939
940 ;;; Find or make a new node for INFO.  Value is the NODE found or
941 ;;; made; NIL if not enough information exists to make a NODE for INFO.
942 (defun lookup-node (info)
943   (when info
944     (multiple-value-bind (new key)
945         (make-node info)
946       (when (eql (node-name new) 'call-counter)
947         (return-from lookup-node (values nil nil)))
948       (let* ((key (cons (node-name new) key))
949              (found (gethash key *name->node*)))
950         (cond (found
951                (setf (node-start-pc-or-offset found)
952                      (min (node-start-pc-or-offset found)
953                           (node-start-pc-or-offset new)))
954                (setf (node-end-pc-or-offset found)
955                      (max (node-end-pc-or-offset found)
956                           (node-end-pc-or-offset new)))
957                found)
958               (t
959                (let ((call-count-info (gethash (node-name new)
960                                                *encapsulations*)))
961                  (when call-count-info
962                    (setf (node-call-count new)
963                          (car call-count-info))))
964                (setf (gethash key *name->node*) new)
965                new))))))
966
967 ;;; Return a list of all nodes created by LOOKUP-NODE.
968 (defun collect-nodes ()
969   (loop for node being the hash-values of *name->node*
970         collect node))
971
972 ;;; Value is a CALL-GRAPH for the current contents of *SAMPLES*.
973 (defun make-call-graph-1 (max-depth)
974   (let ((elsewhere-count 0)
975         visited-nodes)
976     (with-lookup-tables ()
977       (loop for i below (- (samples-index *samples*) 2) by 2
978             with depth = 0
979             for debug-info = (aref (samples-vector *samples*) i)
980             for next-info = (aref (samples-vector *samples*)
981                                   (+ i 2))
982             do (if (eq debug-info 'trace-start)
983                    (setf depth 0)
984                    (let ((callee (lookup-node debug-info))
985                          (caller (unless (eq next-info 'trace-start)
986                                    (lookup-node next-info))))
987                      (when (< depth max-depth)
988                        (when (zerop depth)
989                          (setf visited-nodes nil)
990                          (cond (callee
991                                 (incf (node-accrued-count callee))
992                                 (incf (node-count callee)))
993                                (t
994                                 (incf elsewhere-count))))
995                        (incf depth)
996                        (when callee
997                          (push callee visited-nodes))
998                        (when caller
999                          (unless (member caller visited-nodes)
1000                            (incf (node-accrued-count caller)))
1001                          (when callee
1002                            (let ((call (find callee (node-edges caller)
1003                                              :key #'call-vertex)))
1004                              (pushnew caller (node-callers callee))
1005                              (if call
1006                                  (unless (member caller visited-nodes)
1007                                    (incf (call-count call)))
1008                                  (push (make-call callee)
1009                                        (node-edges caller))))))))))
1010       (let ((sorted-nodes (sort (collect-nodes) #'> :key #'node-count)))
1011         (loop for node in sorted-nodes and i from 1 do
1012               (setf (node-index node) i))
1013         (%make-call-graph :nsamples (samples-trace-count *samples*)
1014                           :sample-interval (if (eq (samples-mode *samples*)
1015                                                    :alloc)
1016                                                (samples-alloc-interval *samples*)
1017                                                (samples-sample-interval *samples*))
1018                           :sampling-mode (samples-mode *samples*)
1019                           :sampled-threads (samples-sampled-threads *samples*)
1020                           :elsewhere-count elsewhere-count
1021                           :vertices sorted-nodes)))))
1022
1023 ;;; Reduce CALL-GRAPH to a dag, creating CYCLE structures for call
1024 ;;; cycles.
1025 (defun reduce-call-graph (call-graph)
1026   (let ((cycle-no 0))
1027     (flet ((make-one-cycle (vertices edges)
1028              (let* ((name (format nil "<Cycle ~d>" (incf cycle-no)))
1029                     (count (loop for v in vertices sum (node-count v))))
1030                (make-cycle :name name
1031                            :index cycle-no
1032                            :count count
1033                            :scc-vertices vertices
1034                            :edges edges))))
1035       (reduce-graph call-graph #'make-one-cycle))))
1036
1037 ;;; For all nodes in CALL-GRAPH, compute times including the time
1038 ;;; spent in functions called from them.  Note that the call-graph
1039 ;;; vertices are in reverse topological order, children first, so we
1040 ;;; will have computed accrued counts of called functions before they
1041 ;;; are used to compute accrued counts for callers.
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 ;;; Return a CALL-GRAPH structure for the current contents of
1051 ;;; *SAMPLES*.  The result contain a list of nodes sorted by self-time
1052 ;;; in the FLAT-NODES slot, and a dag in VERTICES, with call cycles
1053 ;;; reduced to CYCLE structures.
1054 (defun make-call-graph (max-depth)
1055   (stop-profiling)
1056   (show-progress "~&Computing call graph ")
1057   (let ((call-graph (without-gcing (make-call-graph-1 max-depth))))
1058     (setf (call-graph-flat-nodes call-graph)
1059           (copy-list (graph-vertices call-graph)))
1060     (show-progress "~&Finding cycles")
1061     #+nil
1062     (reduce-call-graph call-graph)
1063     (show-progress "~&Propagating counts")
1064     #+nil
1065     (compute-accrued-counts call-graph)
1066     call-graph))
1067
1068 \f
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   (if (> count 0)
1076       (* 100.0 (/ count (call-graph-nsamples call-graph)))
1077       0))
1078
1079 (defun print-call-graph-header (call-graph)
1080   (let ((nsamples (call-graph-nsamples call-graph))
1081         (interval (call-graph-sample-interval call-graph))
1082         (ncycles (loop for v in (graph-vertices call-graph)
1083                        count (scc-p v))))
1084     (if (eq (call-graph-sampling-mode call-graph) :alloc)
1085         (format t "~2&Number of samples:     ~d~%~
1086                       Alloc interval:        ~a regions (approximately ~a kB)~%~
1087                       Total sampling amount: ~a regions (approximately ~a kB)~%~
1088                       Number of cycles:      ~d~%~
1089                       Sampled threads:~{~%   ~S~}~2%"
1090                 nsamples
1091                 interval
1092                 (truncate (* interval *alloc-region-size*) 1024)
1093                 (* nsamples interval)
1094                 (truncate (* nsamples interval *alloc-region-size*) 1024)
1095                 ncycles
1096                 (call-graph-sampled-threads call-graph))
1097         (format t "~2&Number of samples:   ~d~%~
1098                       Sample interval:     ~f seconds~%~
1099                       Total sampling time: ~f seconds~%~
1100                       Number of cycles:    ~d~%~
1101                       Sampled threads:~{~% ~S~}~2%"
1102                 nsamples
1103                 interval
1104                 (* nsamples interval)
1105                 ncycles
1106                 (call-graph-sampled-threads call-graph)))))
1107
1108 (declaim (type (member :samples :cumulative-samples) *report-sort-by*))
1109 (defvar *report-sort-by* :samples
1110   "Method for sorting the flat report: either by :SAMPLES or by :CUMULATIVE-SAMPLES.")
1111
1112 (declaim (type (member :descending :ascending) *report-sort-order*))
1113 (defvar *report-sort-order* :descending
1114   "Order for sorting the flat report: either :DESCENDING or :ASCENDING.")
1115
1116 (defun print-flat (call-graph &key (stream *standard-output*) max
1117                    min-percent (print-header t)
1118                    (sort-by *report-sort-by*)
1119                    (sort-order *report-sort-order*))
1120   (declare (type (member :descending :ascending) sort-order)
1121            (type (member :samples :cumulative-samples) sort-by))
1122   (let ((*standard-output* stream)
1123         (*print-pretty* nil)
1124         (total-count 0)
1125         (total-percent 0)
1126         (min-count (if min-percent
1127                        (round (* (/ min-percent 100.0)
1128                                  (call-graph-nsamples call-graph)))
1129                        0)))
1130     (when print-header
1131       (print-call-graph-header call-graph))
1132     (format t "~&           Self        Total        Cumul~%")
1133     (format t "~&  Nr  Count     %  Count     %  Count     %    Calls  Function~%")
1134     (print-separator)
1135     (let ((elsewhere-count (call-graph-elsewhere-count call-graph))
1136           (i 0)
1137           (nodes (stable-sort (copy-list (call-graph-flat-nodes call-graph))
1138                               (let ((cmp (if (eq :descending sort-order) #'> #'<)))
1139                                 (multiple-value-bind (primary secondary)
1140                                     (if (eq :samples sort-by)
1141                                         (values #'node-count #'node-accrued-count)
1142                                         (values #'node-accrued-count #'node-count))
1143                                   (lambda (x y)
1144                                     (let ((cx (funcall primary x))
1145                                           (cy (funcall primary y)))
1146                                       (if (= cx cy)
1147                                           (funcall cmp (funcall secondary x) (funcall secondary y))
1148                                           (funcall cmp cx cy)))))))))
1149       (dolist (node nodes)
1150         (when (or (and max (> (incf i) max))
1151                   (< (node-count node) min-count))
1152           (return))
1153         (let* ((count (node-count node))
1154                (percent (samples-percent call-graph count))
1155                (accrued-count (node-accrued-count node))
1156                (accrued-percent (samples-percent call-graph accrued-count)))
1157           (incf total-count count)
1158           (incf total-percent percent)
1159           (format t "~&~4d ~6d ~5,1f ~6d ~5,1f ~6d ~5,1f ~8@a  ~s~%"
1160                   (incf i)
1161                   count
1162                   percent
1163                   accrued-count
1164                   accrued-percent
1165                   total-count
1166                   total-percent
1167                   (or (node-call-count node) "-")
1168                   (node-name node))
1169           (finish-output)))
1170       (print-separator)
1171       (format t "~&     ~6d ~5,1f~36a elsewhere~%"
1172               elsewhere-count
1173               (samples-percent call-graph elsewhere-count)
1174               ""))))
1175
1176 (defun print-cycles (call-graph)
1177   (when (some #'cycle-p (graph-vertices call-graph))
1178     (format t "~&                            Cycle~%")
1179     (format t "~& Count     %                   Parts~%")
1180     (do-vertices (node call-graph)
1181       (when (cycle-p node)
1182         (flet ((print-info (indent index count percent name)
1183                  (format t "~&~6d ~5,1f ~11@t ~V@t  ~s [~d]~%"
1184                          count percent indent name index)))
1185           (print-separator)
1186           (format t "~&~6d ~5,1f                ~a...~%"
1187                   (node-count node)
1188                   (samples-percent call-graph (cycle-count node))
1189                   (node-name node))
1190           (dolist (v (vertex-scc-vertices node))
1191             (print-info 4 (node-index v) (node-count v)
1192                         (samples-percent call-graph (node-count v))
1193                         (node-name v))))))
1194     (print-separator)
1195     (format t "~2%")))
1196
1197 (defun print-graph (call-graph &key (stream *standard-output*)
1198                     max min-percent)
1199   (let ((*standard-output* stream)
1200         (*print-pretty* nil))
1201     (print-call-graph-header call-graph)
1202     (print-cycles call-graph)
1203     (flet ((find-call (from to)
1204              (find to (node-edges from) :key #'call-vertex))
1205            (print-info (indent index count percent name)
1206              (format t "~&~6d ~5,1f ~11@t ~V@t  ~s [~d]~%"
1207                      count percent indent name index)))
1208       (format t "~&                               Callers~%")
1209       (format t "~&                 Total.     Function~%")
1210       (format t "~& Count     %  Count     %      Callees~%")
1211       (do-vertices (node call-graph)
1212         (print-separator)
1213         ;;
1214         ;; Print caller information.
1215         (dolist (caller (node-callers node))
1216           (let ((call (find-call caller node)))
1217             (print-info 4 (node-index caller)
1218                         (call-count call)
1219                         (samples-percent call-graph (call-count call))
1220                         (node-name caller))))
1221         ;; Print the node itself.
1222         (format t "~&~6d ~5,1f ~6d ~5,1f   ~s [~d]~%"
1223                 (node-count node)
1224                 (samples-percent call-graph (node-count node))
1225                 (node-accrued-count node)
1226                 (samples-percent call-graph (node-accrued-count node))
1227                 (node-name node)
1228                 (node-index node))
1229         ;; Print callees.
1230         (do-edges (call called node)
1231           (print-info 4 (node-index called)
1232                       (call-count call)
1233                       (samples-percent call-graph (call-count call))
1234                       (node-name called))))
1235       (print-separator)
1236       (format t "~2%")
1237       (print-flat call-graph :stream stream :max max
1238                   :min-percent min-percent :print-header nil))))
1239
1240 (defun report (&key (type :graph) max min-percent call-graph
1241                ((:sort-by *report-sort-by*) *report-sort-by*)
1242                ((:sort-order *report-sort-order*) *report-sort-order*)
1243                (stream *standard-output*) ((:show-progress *show-progress*)))
1244   "Report statistical profiling results.  The following keyword
1245    args are recognized:
1246
1247    :TYPE <type>
1248       Specifies the type of report to generate.  If :FLAT, show
1249       flat report, if :GRAPH show a call graph and a flat report.
1250       If nil, don't print out a report.
1251
1252    :STREAM <stream>
1253       Specify a stream to print the report on.  Default is
1254       *STANDARD-OUTPUT*.
1255
1256    :MAX <max>
1257       Don't show more than <max> entries in the flat report.
1258
1259    :MIN-PERCENT <min-percent>
1260       Don't show functions taking less than <min-percent> of the
1261       total time in the flat report.
1262
1263    :SORT-BY <column>
1264       If :SAMPLES, sort flat report by number of samples taken.
1265       If :CUMULATIVE-SAMPLES, sort flat report by cumulative number of samples
1266       taken (shows how much time each function spent on stack.) Default
1267       is *REPORT-SORT-BY*.
1268
1269    :SORT-ORDER <order>
1270       If :DESCENDING, sort flat report in descending order. If :ASCENDING,
1271       sort flat report in ascending order. Default is *REPORT-SORT-ORDER*.
1272
1273    :SHOW-PROGRESS <bool>
1274      If true, print progress messages while generating the call graph.
1275
1276    :CALL-GRAPH <graph>
1277      Print a report from <graph> instead of the latest profiling
1278      results.
1279
1280 Value of this function is a CALL-GRAPH object representing the
1281 resulting call-graph, or NIL if there are no samples (eg. right after
1282 calling RESET.)
1283
1284 Profiling is stopped before the call graph is generated."
1285   (cond (*samples*
1286          (let ((graph (or call-graph (make-call-graph most-positive-fixnum))))
1287            (ecase type
1288              (:flat
1289               (print-flat graph :stream stream :max max :min-percent min-percent))
1290              (:graph
1291               (print-graph graph :stream stream :max max :min-percent min-percent))
1292              ((nil)))
1293            graph))
1294         (t
1295          (format stream "~&; No samples to report.~%")
1296          nil)))
1297
1298 ;;; Interface to DISASSEMBLE
1299
1300 (defun sample-pc-from-pc-or-offset (sample pc-or-offset)
1301   (etypecase sample
1302     ;; Assembly routines or foreign functions don't move around, so we've
1303     ;; stored a raw PC
1304     ((or sb-kernel:code-component string)
1305      pc-or-offset)
1306     ;; Lisp functions might move, so we've stored a offset from the
1307     ;; start of the code component.
1308     (sb-di::compiled-debug-fun
1309      (let* ((component (sb-di::compiled-debug-fun-component sample))
1310             (start-pc (code-start component)))
1311        (+ start-pc pc-or-offset)))))
1312
1313 (defun add-disassembly-profile-note (chunk stream dstate)
1314   (declare (ignore chunk stream))
1315   (when *samples*
1316     (let* ((location (+ (sb-disassem::seg-virtual-location
1317                          (sb-disassem:dstate-segment dstate))
1318                         (sb-disassem::dstate-cur-offs dstate)))
1319            (samples (loop with index = (samples-index *samples*)
1320                           for x from 0 below (- index 2) by 2
1321                           for last-sample = nil then sample
1322                           for sample = (aref (samples-vector *samples*) x)
1323                           for pc-or-offset = (aref (samples-vector *samples*)
1324                                                    (1+ x))
1325                           when (and sample (eq last-sample 'trace-start))
1326                           count (= location
1327                                    (sample-pc-from-pc-or-offset sample
1328                                                                 pc-or-offset)))))
1329       (unless (zerop samples)
1330         (sb-disassem::note (format nil "~A/~A samples"
1331                                    samples (samples-trace-count *samples*))
1332                            dstate)))))
1333
1334 (pushnew 'add-disassembly-profile-note sb-disassem::*default-dstate-hooks*)
1335
1336 \f
1337 ;;;; Call counting
1338
1339 ;;; The following functions tell sb-sprof to do call count profiling
1340 ;;; for the named functions in addition to normal statistical
1341 ;;; profiling.  The benefit of this over using SB-PROFILE is that this
1342 ;;; encapsulation is a lot more lightweight, due to not needing to
1343 ;;; track cpu usage / consing. (For example, compiling asdf 20 times
1344 ;;; took 13s normally, 15s with call counting for all functions in
1345 ;;; SB-C, and 94s with SB-PROFILE profiling SB-C).
1346
1347 (defun profile-call-counts (&rest names)
1348   "Mark the functions named by NAMES as being subject to call counting
1349 during statistical profiling. If a string is used as a name, it will
1350 be interpreted as a package name. In this case call counting will be
1351 done for all functions with names like X or (SETF X), where X is a symbol
1352 with the package as its home package."
1353   (dolist (name names)
1354     (if (stringp name)
1355         (let ((package (find-package name)))
1356           (do-symbols (symbol package)
1357             (when (eql (symbol-package symbol) package)
1358               (dolist (function-name (list symbol (list 'setf symbol)))
1359                 (profile-call-counts-for-function function-name)))))
1360         (profile-call-counts-for-function name))))
1361
1362 (defun profile-call-counts-for-function (function-name)
1363   (unless (gethash function-name *encapsulations*)
1364     (setf (gethash function-name *encapsulations*) nil)))
1365
1366 (defun unprofile-call-counts ()
1367   "Clear all call counting information. Call counting will be done for no
1368 functions during statistical profiling."
1369   (clrhash *encapsulations*))
1370
1371 ;;; Called when profiling is started to enable the call counting
1372 ;;; encapsulation. Wrap all the call counted functions
1373 (defun enable-call-counting ()
1374   (maphash (lambda (k v)
1375              (declare (ignore v))
1376              (enable-call-counting-for-function k))
1377            *encapsulations*))
1378
1379 ;;; Called when profiling is stopped to disable the encapsulation. Restore
1380 ;;; the original functions.
1381 (defun disable-call-counting ()
1382   (maphash (lambda (k v)
1383              (when v
1384                (assert (cdr v))
1385                (without-package-locks
1386                  (setf (fdefinition k) (cdr v)))
1387                (setf (cdr v) nil)))
1388            *encapsulations*))
1389
1390 (defun enable-call-counting-for-function (function-name)
1391   (let ((info (gethash function-name *encapsulations*)))
1392     ;; We should never try to encapsulate an fdefn multiple times.
1393     (assert (or (null info)
1394                 (null (cdr info))))
1395     (when (and (fboundp function-name)
1396                (or (not (symbolp function-name))
1397                    (and (not (special-operator-p function-name))
1398                         (not (macro-function function-name)))))
1399       (let* ((original-fun (fdefinition function-name))
1400              (info (cons 0 original-fun)))
1401         (setf (gethash function-name *encapsulations*) info)
1402         (without-package-locks
1403           (setf (fdefinition function-name)
1404                 (sb-int:named-lambda call-counter (sb-int:&more more-context more-count)
1405                   (declare (optimize speed (safety 0)))
1406                   ;; 2^59 calls should be enough for anybody, and it
1407                   ;; allows using fixnum arithmetic on x86-64. 2^32
1408                   ;; isn't enough, so we can't do that on 32 bit platforms.
1409                   (incf (the (unsigned-byte 59)
1410                           (car info)))
1411                   (multiple-value-call original-fun
1412                     (sb-c:%more-arg-values more-context
1413                                            0
1414                                            more-count)))))))))
1415
1416 \f
1417 ;;; silly examples
1418
1419 (defun test-0 (n &optional (depth 0))
1420   (declare (optimize (debug 3)))
1421   (when (< depth n)
1422     (dotimes (i n)
1423       (test-0 n (1+ depth))
1424       (test-0 n (1+ depth)))))
1425
1426 (defun test ()
1427   (with-profiling (:reset t :max-samples 1000 :report :graph)
1428     (test-0 7)))
1429
1430 (defun consalot ()
1431   (let ((junk '()))
1432     (loop repeat 10000 do
1433          (push (make-array 10) junk))
1434     junk))
1435
1436 (defun consing-test ()
1437   ;; 0.0001 chosen so that it breaks rather reliably when sprof does not
1438   ;; respect pseudo atomic.
1439   (with-profiling (:reset t :sample-interval 0.0001 :report :graph :loop nil)
1440     (let ((target (+ (get-universal-time) 15)))
1441       (princ #\.)
1442       (force-output)
1443       (loop
1444          while (< (get-universal-time) target)
1445          do (consalot)))))
1446
1447
1448 ;;; provision
1449 (provide 'sb-sprof)
1450
1451 ;;; end of file