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)
 102   (:export #:*sample-interval* #:*max-samples*
 103            #:start-sampling #:stop-sampling #:with-sampling
 104            #:with-profiling #:start-profiling #:stop-profiling
 105            #:reset #:report))
 106
 107 (in-package #:sb-sprof)
 108
 109 \f
 110 ;;;; Graph Utilities
 111
 112 (defstruct (vertex (:constructor make-vertex)
 113                    (:constructor make-scc (scc-vertices edges)))
 114   (visited     nil :type boolean)
 115   (root        nil :type (or null vertex))
 116   (dfn           0 :type fixnum)
 117   (edges        () :type list)
 118   (scc-vertices () :type list))
 119
 120 (defstruct edge
 121   (vertex (sb-impl::missing-arg) :type vertex))
 122
 123 (defstruct graph
 124   (vertices () :type list))
 125
 126 (declaim (inline scc-p))
 127 (defun scc-p (vertex)
 128   (not (null (vertex-scc-vertices vertex))))
 129
 130 (defmacro do-vertices ((vertex graph) &body body)
 131   `(dolist (,vertex (graph-vertices ,graph))
 132      ,@body))
 133
 134 (defmacro do-edges ((edge edge-to vertex) &body body)
 135   `(dolist (,edge (vertex-edges ,vertex))
 136      (let ((,edge-to (edge-vertex ,edge)))
 137        ,@body)))
 138
 139 (defun self-cycle-p (vertex)
 140   (do-edges (e to vertex)
 141     (when (eq to vertex)
 142       (return t))))
 143
 144 (defun map-vertices (fn vertices)
 145   (dolist (v vertices)
 146     (setf (vertex-visited v) nil))
 147   (dolist (v vertices)
 148     (unless (vertex-visited v)
 149       (funcall fn v))))
 150
 151 ;;; Eeko Nuutila, Eljas Soisalon-Soininen, around 1992.  Improves on
 152 ;;; Tarjan's original algorithm by not using the stack when processing
 153 ;;; trivial components.  Trivial components should appear frequently
 154 ;;; in a call-graph such as ours, I think.  Same complexity O(V+E) as
 155 ;;; Tarjan.
 156 (defun strong-components (vertices)
 157   (let ((in-component (make-array (length vertices)
 158                                   :element-type 'boolean
 159                                   :initial-element nil))
 160         (stack ())
 161         (components ())
 162         (dfn -1))
 163     (labels ((min-root (x y)
 164                (let ((rx (vertex-root x))
 165                      (ry (vertex-root y)))
 166                  (if (< (vertex-dfn rx) (vertex-dfn ry))
 167                      rx
 168                      ry)))
 169              (in-component (v)
 170                (aref in-component (vertex-dfn v)))
 171              ((setf in-component) (in v)
 172                (setf (aref in-component (vertex-dfn v)) in))
 173              (vertex-> (x y)
 174                (> (vertex-dfn x) (vertex-dfn y)))
 175              (visit (v)
 176                (setf (vertex-dfn v) (incf dfn)
 177                      (in-component v) nil
 178                      (vertex-root v) v
 179                      (vertex-visited v) t)
 180                (do-edges (e w v)
 181                  (unless (vertex-visited w)
 182                    (visit w))
 183                  (unless (in-component w)
 184                    (setf (vertex-root v) (min-root v w))))
 185                (if (eq v (vertex-root v))
 186                    (loop while (and stack (vertex-> (car stack) v))
 187                          as w = (pop stack)
 188                          collect w into this-component
 189                          do (setf (in-component w) t)
 190                          finally
 191                            (setf (in-component v) t)
 192                            (push (cons v this-component) components))
 193                    (push v stack))))
 194       (map-vertices #'visit vertices)
 195       components)))
 196
 197 ;;; Given a dag as a list of vertices, return the list sorted
 198 ;;; topologically, children first.
 199 (defun topological-sort (dag)
 200   (let ((sorted ())
 201         (dfn -1))
 202     (labels ((rec-sort (v)
 203                (setf (vertex-visited v) t)
 204                (setf (vertex-dfn v) (incf dfn))
 205                (dolist (e (vertex-edges v))
 206                  (unless (vertex-visited (edge-vertex e))
 207                    (rec-sort (edge-vertex e))))
 208                (push v sorted)))
 209       (map-vertices #'rec-sort dag)
 210       (nreverse sorted))))
 211
 212 ;;; Reduce graph G to a dag by coalescing strongly connected components
 213 ;;; into vertices.  Sort the result topologically.
 214 (defun reduce-graph (graph &optional (scc-constructor #'make-scc))
 215   (sb-int:collect ((sccs) (trivial))
 216     (dolist (c (strong-components (graph-vertices graph)))
 217       (if (or (cdr c) (self-cycle-p (car c)))
 218           (sb-int:collect ((outgoing))
 219             (dolist (v c)
 220               (do-edges (e w v)
 221                 (unless (member w c)
 222                   (outgoing e))))
 223             (sccs (funcall scc-constructor c (outgoing))))
 224           (trivial (car c))))
 225     (dolist (scc (sccs))
 226       (dolist (v (trivial))
 227         (do-edges (e w v)
 228           (when (member w (vertex-scc-vertices scc))
 229             (setf (edge-vertex e) scc)))))
 230     (setf (graph-vertices graph)
 231           (topological-sort (nconc (sccs) (trivial))))))
 232
 233 \f
 234 ;;;; AA Trees
 235
 236 ;;; An AA tree is a red-black tree with the extra condition that left
 237 ;;; children may not be red.  This condition simplifies the red-black
 238 ;;; algorithm.  It eliminates half of the restructuring cases, and
 239 ;;; simplifies the delete algorithm.
 240
 241 (defstruct (aa-node (:conc-name aa-))
 242   (left  nil :type (or null aa-node))
 243   (right nil :type (or null aa-node))
 244   (level   0 :type integer)
 245   (data  nil :type t))
 246
 247 (defvar *null-node*
 248   (let ((node (make-aa-node)))
 249     (setf (aa-left node) node)
 250     (setf (aa-right node) node)
 251     node))
 252
 253 (defstruct aa-tree
 254   (root *null-node* :type aa-node))
 255
 256 (declaim (inline skew split rotate-with-left-child rotate-with-right-child))
 257
 258 (defun rotate-with-left-child (k2)
 259   (let ((k1 (aa-left k2)))
 260     (setf (aa-left k2) (aa-right k1))
 261     (setf (aa-right k1) k2)
 262     k1))
 263
 264 (defun rotate-with-right-child (k1)
 265   (let ((k2 (aa-right k1)))
 266     (setf (aa-right k1) (aa-left k2))
 267     (setf (aa-left k2) k1)
 268     k2))
 269
 270 (defun skew (aa)
 271   (if (= (aa-level (aa-left aa)) (aa-level aa))
 272       (rotate-with-left-child aa)
 273       aa))
 274
 275 (defun split (aa)
 276   (when (= (aa-level (aa-right (aa-right aa)))
 277            (aa-level aa))
 278     (setq aa (rotate-with-right-child aa))
 279     (incf (aa-level aa)))
 280   aa)
 281
 282 (macrolet ((def (name () &body body)
 283              (let ((name (sb-int::symbolicate 'aa- name)))
 284                `(defun ,name (item tree &key
 285                               (test-< #'<) (test-= #'=)
 286                               (node-key #'identity) (item-key #'identity))
 287                   (let ((.item-key. (funcall item-key item)))
 288                     (flet ((item-< (node)
 289                              (funcall test-< .item-key.
 290                                       (funcall node-key (aa-data node))))
 291                            (item-= (node)
 292                              (funcall test-= .item-key.
 293                                       (funcall node-key (aa-data node)))))
 294                       (declare (inline item-< item-=))
 295                       ,@body))))))
 296
 297   (def insert ()
 298     (labels ((insert-into (aa)
 299                (cond ((eq aa *null-node*)
 300                       (setq aa (make-aa-node :data item
 301                                              :left *null-node*
 302                                              :right *null-node*)))
 303                      ((item-= aa)
 304                       (return-from insert-into aa))
 305                      ((item-< aa)
 306                       (setf (aa-left aa) (insert-into (aa-left aa))))
 307                      (t
 308                       (setf (aa-right aa) (insert-into (aa-right aa)))))
 309                (split (skew aa))))
 310       (setf (aa-tree-root tree)
 311             (insert-into (aa-tree-root tree)))))
 312
 313   (def delete ()
 314     (let ((deleted-node *null-node*)
 315           (last-node nil))
 316       (labels ((remove-from (aa)
 317                  (unless (eq aa *null-node*)
 318                    (setq last-node aa)
 319                    (if (item-< aa)
 320                        (setf (aa-left aa) (remove-from (aa-left aa)))
 321                        (progn
 322                          (setq deleted-node aa)
 323                          (setf (aa-right aa) (remove-from (aa-right aa)))))
 324                    (cond ((eq aa last-node)
 325                           ;;
 326                           ;; If at the bottom of the tree, and item
 327                           ;; is present, delete it.
 328                           (when (and (not (eq deleted-node *null-node*))
 329                                      (item-= deleted-node))
 330                             (setf (aa-data deleted-node) (aa-data aa))
 331                             (setq deleted-node *null-node*)
 332                             (setq aa (aa-right aa))))
 333                          ;;
 334                          ;; Otherwise not at bottom of tree; rebalance.
 335                          ((or (< (aa-level (aa-left aa))
 336                                  (1- (aa-level aa)))
 337                               (< (aa-level (aa-right aa))
 338                                  (1- (aa-level aa))))
 339                           (decf (aa-level aa))
 340                           (when (> (aa-level (aa-right aa)) (aa-level aa))
 341                             (setf (aa-level (aa-right aa)) (aa-level aa)))
 342                           (setq aa (skew aa))
 343                           (setf (aa-right aa) (skew (aa-right aa)))
 344                           (setf (aa-right (aa-right aa))
 345                                 (skew (aa-right (aa-right aa))))
 346                           (setq aa (split aa))
 347                           (setf (aa-right aa) (split (aa-right aa))))))
 348                  aa))
 349         (setf (aa-tree-root tree)
 350               (remove-from (aa-tree-root tree))))))
 351
 352   (def find ()
 353     (let ((current (aa-tree-root tree)))
 354       (setf (aa-data *null-node*) item)
 355       (loop
 356          (cond ((eq current *null-node*)
 357                 (return (values nil nil)))
 358                ((item-= current)
 359                 (return (values (aa-data current) t)))
 360                ((item-< current)
 361                 (setq current (aa-left current)))
 362                (t
 363                 (setq current (aa-right current))))))))
 364
 365 \f
 366 ;;;; Other Utilities
 367
 368 ;;; Sort the subsequence of Vec in the interval [From To] using
 369 ;;; comparison function Test.  Assume each element to sort consists of
 370 ;;; Element-Size array slots, and that the slot Key-Offset contains
 371 ;;; the sort key.
 372 (defun qsort (vec &key (element-size 1) (key-offset 0)
 373               (from 0) (to (- (length vec) element-size)))
 374   (declare (type fixnum to from element-size key-offset))
 375   (declare (type (simple-array address) vec))
 376   (labels ((rotate (i j)
 377              (declare (fixnum i j))
 378              (loop repeat element-size
 379                    for i from i and j from j do
 380                      (rotatef (aref vec i) (aref vec j))))
 381            (key (i)
 382              (aref vec (+ i key-offset)))
 383            (rec-sort (from to)
 384              (declare (fixnum to from))
 385              (when (> to from)
 386                (let* ((mid (* element-size
 387                               (round (+ (/ from element-size)
 388                                         (/ to element-size))
 389                                      2)))
 390                       (i from)
 391                       (j (+ to element-size))
 392                       (p (key mid)))
 393                  (declare (fixnum mid i j))
 394                  (rotate mid from)
 395                  (loop
 396                     (loop do (incf i element-size)
 397                           until (or (> i to)
 398                                     ;; QSORT used to take a test
 399                                     ;; parameter which was funcalled
 400                                     ;; here. This caused some consing,
 401                                     ;; which is problematic since
 402                                     ;; QSORT is indirectly called in
 403                                     ;; an after-gc-hook. So just
 404                                     ;; hardcode >, which would've been
 405                                     ;; used for the test anyway.
 406                                     ;; --JES, 2004-07-09
 407                                     (> p (key i))))
 408                     (loop do (decf j element-size)
 409                           until (or (<= j from)
 410                                     ;; As above.
 411                                     (> (key j) p)))
 412                     (when (< j i) (return))
 413                     (rotate i j))
 414                  (rotate from j)
 415                  (rec-sort from (- j element-size))
 416                  (rec-sort i to)))))
 417     (rec-sort from to)
 418     vec))
 419
 420 \f
 421 ;;;; The Profiler
 422
 423 (deftype address ()
 424   "Type used for addresses, for instance, program counters,
 425    code start/end locations etc."
 426   '(unsigned-byte #.sb-vm::n-machine-word-bits))
 427
 428 (defconstant +unknown-address+ 0
 429   "Constant representing an address that cannot be determined.")
 430
 431 ;;; A call graph.  Vertices are NODE structures, edges are CALL
 432 ;;; structures.
 433 (defstruct (call-graph (:include graph)
 434                        (:constructor %make-call-graph))
 435   ;; the value of *Sample-Interval* at the time the graph was created
 436   (sample-interval (sb-impl::missing-arg) :type number)
 437   ;; number of samples taken
 438   (nsamples (sb-impl::missing-arg) :type sb-impl::index)
 439   ;; sample count for samples not in any function
 440   (elsewhere-count (sb-impl::missing-arg) :type sb-impl::index)
 441   ;; a flat list of NODEs, sorted by sample count
 442   (flat-nodes () :type list))
 443
 444 ;;; A node in a call graph, representing a function that has been
 445 ;;; sampled.  The edges of a node are CALL structures that represent
 446 ;;; functions called from a given node.
 447 (defstruct (node (:include vertex)
 448                  (:constructor %make-node))
 449   ;; A numeric label for the node.  The most frequently called function
 450   ;; gets label 1.  This is just for identification purposes in the
 451   ;; profiling report.
 452   (index 0 :type fixnum)
 453   ;; start and end address of the function's code
 454   (start-pc 0 :type address)
 455   (end-pc 0 :type address)
 456   ;; the name of the function
 457   (name nil :type t)
 458   ;; sample count for this function
 459   (count 0 :type fixnum)
 460   ;; count including time spent in functions called from this one
 461   (accrued-count 0 :type fixnum)
 462   ;; list of NODEs for functions calling this one
 463   (callers () :type list))
 464
 465 ;;; A cycle in a call graph.  The functions forming the cycle are
 466 ;;; found in the SCC-VERTICES slot of the VERTEX structure.
 467 (defstruct (cycle (:include node)))
 468
 469 ;;; An edge in a call graph.  EDGE-VERTEX is the function being
 470 ;;; called.
 471 (defstruct (call (:include edge)
 472                  (:constructor make-call (vertex)))
 473   ;; number of times the call was sampled
 474   (count 1 :type sb-impl::index))
 475
 476 ;;; Info about a function in dynamic-space.  This is used to track
 477 ;;; address changes of functions during GC.
 478 (defstruct (dyninfo (:constructor make-dyninfo (code start end)))
 479   ;; component this info is for
 480   (code (sb-impl::missing-arg) :type sb-kernel::code-component)
 481   ;; current start and end address of the component
 482   (start (sb-impl::missing-arg) :type address)
 483   (end (sb-impl::missing-arg) :type address)
 484   ;; new start address of the component, after GC.
 485   (new-start 0 :type address))
 486
 487 (defmethod print-object ((call-graph call-graph) stream)
 488   (print-unreadable-object (call-graph stream :type t :identity t)
 489     (format stream "~d samples" (call-graph-nsamples call-graph))))
 490
 491 (defmethod print-object ((node node) stream)
 492   (print-unreadable-object (node stream :type t :identity t)
 493     (format stream "~s [~d]" (node-name node) (node-index node))))
 494
 495 (defmethod print-object ((call call) stream)
 496   (print-unreadable-object (call stream :type t :identity t)
 497     (format stream "~s [~d]" (node-name (call-vertex call))
 498             (node-index (call-vertex call)))))
 499
 500 (deftype report-type ()
 501   '(member nil :flat :graph))
 502
 503 (defvar *sample-interval* 0.01
 504   "Default number of seconds between samples.")
 505 (declaim (number *sample-interval*))
 506
 507 (defvar *max-samples* 50000
 508   "Default number of samples taken.")
 509 (declaim (type sb-impl::index *max-samples*))
 510
 511 (defconstant +sample-size+
 512   #+(or x86 x86-64) 8
 513   #-(or x86 x86-64) 2)
 514
 515 (defvar *samples* nil)
 516 (declaim (type (or null (vector address)) *samples*))
 517
 518 (defvar *samples-index* 0)
 519 (declaim (type sb-impl::index *samples-index*))
 520
 521 (defvar *profiling* nil)
 522 (defvar *sampling* nil)
 523 (declaim (type boolean *profiling* *sampling*))
 524
 525 (defvar *dynamic-space-code-info* ())
 526 (declaim (type list *dynamic-space-code-info*))
 527
 528 (defvar *show-progress* nil)
 529
 530 (defvar *old-sampling* nil)
 531
 532 (defun turn-off-sampling ()
 533   (setq *old-sampling* *sampling*)
 534   (setq *sampling* nil))
 535
 536 (defun turn-on-sampling ()
 537   (setq *sampling* *old-sampling*))
 538
 539 (defun show-progress (format-string &rest args)
 540   (when *show-progress*
 541     (apply #'format t format-string args)
 542     (finish-output)))
 543
 544 (defun start-sampling ()
 545   "Switch on statistical sampling."
 546   (setq *sampling* t))
 547
 548 (defun stop-sampling ()
 549   "Switch off statistical sampling."
 550   (setq *sampling* nil))
 551
 552 (defmacro with-sampling ((&optional (on t)) &body body)
 553   "Evaluate body with statistical sampling turned on or off."
 554   `(let ((*sampling* ,on))
 555      ,@body))
 556
 557 (defun sort-samples (key-offset)
 558   "Sort *Samples* using comparison Test.  Key must be one of
 559    :Pc or :Return-Pc for sorting by pc or return pc."
 560   (when (plusp *samples-index*)
 561     (qsort *samples*
 562            :from 0
 563            :to (- *samples-index* +sample-size+)
 564            :element-size +sample-size+
 565            :key-offset key-offset)))
 566
 567 (defun record (pc)
 568   (declare (type address pc))
 569   (setf (aref *samples* *samples-index*) pc)
 570   (incf *samples-index*))
 571
 572 ;;; SIGPROF handler.  Record current PC and return address in
 573 ;;; *SAMPLES*.
 574 #+(or x86 x86-64)
 575 (defun sigprof-handler (signal code scp)
 576   (declare (ignore signal code) (type system-area-pointer scp))
 577   (sb-sys:with-interrupts
 578     (when (and *sampling*
 579                (< *samples-index* (length *samples*)))
 580       (sb-sys:without-gcing
 581         (locally (declare (optimize (inhibit-warnings 2)))
 582           (with-alien ((scp (* os-context-t) :local scp))
 583             ;; For some reason completely bogus small values for the
 584             ;; frame pointer are returned every now and then, leading
 585             ;; to segfaults. Try to avoid these cases.
 586             ;;
 587             ;; FIXME: Do a more thorough sanity check on ebp, or figure
 588             ;; out why this is happening.
 589             ;; -- JES, 2005-01-11
 590             (when (< (sb-vm::context-register scp #.sb-vm::ebp-offset)
 591                      4096)
 592               (dotimes (i +sample-size+)
 593                 (record 0))
 594               (return-from sigprof-handler nil))
 595             (let* ((pc-ptr (sb-vm:context-pc scp))
 596                    (fp (sb-vm::context-register scp #.sb-vm::ebp-offset)))
 597               (record (sap-int pc-ptr))
 598               (let ((fp (int-sap fp))
 599                     ra)
 600                 (dotimes (i (1- +sample-size+))
 601                   (cond (fp
 602                          (setf (values ra fp)
 603                                (sb-di::x86-call-context fp :depth i))
 604                          (record (if ra
 605                                      (sap-int ra)
 606                                      0)))
 607                         (t
 608                          (record 0))))))))))))
 609
 610 ;; FIXME: On non-x86 platforms we don't yet walk the call stack deeper
 611 ;; than one level.
 612 #-(or x86 x86-64)
 613 (defun sigprof-handler (signal code scp)
 614   (declare (ignore signal code))
 615   (sb-sys:with-interrupts
 616     (when (and *sampling*
 617                (< *samples-index* (length *samples*)))
 618       (sb-sys:without-gcing
 619         (with-alien ((scp (* os-context-t) :local scp))
 620           (locally (declare (optimize (inhibit-warnings 2)))
 621             (let* ((pc-ptr (sb-vm:context-pc scp))
 622                    (fp (sb-vm::context-register scp #.sb-vm::cfp-offset))
 623                    (ra (sap-ref-word
 624                         (int-sap fp)
 625                         (* sb-vm::lra-save-offset sb-vm::n-word-bytes))))
 626               (record (sap-int pc-ptr))
 627               (record ra))))))))
 628
 629 ;;; Map function FN over code objects in dynamic-space.  FN is called
 630 ;;; with two arguments, the object and its size in bytes.
 631 (defun map-dynamic-space-code (fn)
 632   (flet ((call-if-code (obj obj-type size)
 633            (declare (ignore obj-type))
 634            (when (sb-kernel:code-component-p obj)
 635              (funcall fn obj size))))
 636     (sb-vm::map-allocated-objects #'call-if-code :dynamic)))
 637
 638 ;;; Return the start address of CODE.
 639 (defun code-start (code)
 640   (declare (type sb-kernel:code-component code))
 641   (sap-int (sb-kernel:code-instructions code)))
 642
 643 ;;; Return start and end address of CODE as multiple values.
 644 (defun code-bounds (code)
 645   (declare (type sb-kernel:code-component code))
 646   (let* ((start (code-start code))
 647          (end (+ start (sb-kernel:%code-code-size code))))
 648     (values start end)))
 649
 650 (defun record-dyninfo ()
 651   (setf *dynamic-space-code-info* nil)
 652   (flet ((record-address (code size)
 653            (declare (ignore size))
 654            (multiple-value-bind (start end)
 655                (code-bounds code)
 656              (push (make-dyninfo code start end)
 657                    *dynamic-space-code-info*))))
 658     (map-dynamic-space-code #'record-address)))
 659
 660 (defun adjust-samples (offset)
 661   (sort-samples offset)
 662   (let ((sidx 0))
 663     (declare (type sb-impl::index sidx))
 664     (dolist (info *dynamic-space-code-info*)
 665       (unless (= (dyninfo-new-start info) (dyninfo-start info))
 666         (let ((pos (do ((i sidx (+ i +sample-size+)))
 667                        ((= i *samples-index*) nil)
 668                      (declare (type sb-impl::index i))
 669                      (when (<= (dyninfo-start info)
 670                                (aref *samples* (+ i offset))
 671                                (dyninfo-end info))
 672                        (return i)))))
 673           (when pos
 674             (setq sidx pos)
 675             (loop with delta = (- (dyninfo-new-start info)
 676                                   (dyninfo-start info))
 677                   for j from sidx below *samples-index* by +sample-size+
 678                   as pc = (aref *samples* (+ j offset))
 679                   while (<= (dyninfo-start info) pc (dyninfo-end info)) do
 680                     (incf (aref *samples* (+ j offset)) delta)
 681                     (incf sidx +sample-size+))))))))
 682
 683 ;;; This runs from *AFTER-GC-HOOKS*.  Adjust *SAMPLES* for address
 684 ;;; changes of dynamic-space code objects.
 685 (defun adjust-samples-for-address-changes ()
 686   (sb-sys:without-gcing
 687    (turn-off-sampling)
 688    (setq *dynamic-space-code-info*
 689          (sort *dynamic-space-code-info* #'> :key #'dyninfo-start))
 690    (dolist (info *dynamic-space-code-info*)
 691      (setf (dyninfo-new-start info)
 692            (code-start (dyninfo-code info))))
 693    (progn
 694      (dotimes (i +sample-size+)
 695        (adjust-samples i)))
 696    (dolist (info *dynamic-space-code-info*)
 697      (let ((size (- (dyninfo-end info) (dyninfo-start info))))
 698        (setf (dyninfo-start info) (dyninfo-new-start info))
 699        (setf (dyninfo-end info) (+ (dyninfo-new-start info) size))))
 700    (turn-on-sampling)))
 701
 702 (defmacro with-profiling ((&key (sample-interval '*sample-interval*)
 703                                 (max-samples '*max-samples*)
 704                                 (reset nil)
 705                                 show-progress
 706                                 (report nil report-p))
 707                           &body body)
 708   "Repeatedly evaluate Body with statistical profiling turned on.
 709    The following keyword args are recognized:
 710
 711    :Sample-Interval <seconds>
 712      Take a sample every <seconds> seconds.  Default is
 713      *Sample-Interval*.
 714
 715    :Max-Samples <max>
 716      Repeat evaluating body until <max> samples are taken.
 717      Default is *Max-Samples*.
 718
 719    :Report <type>
 720      If specified, call Report with :Type <type> at the end.
 721
 722    :Reset <bool>
 723      It true, call Reset at the beginning."
 724   (declare (type report-type report))
 725   `(let ((*sample-interval* ,sample-interval)
 726          (*max-samples* ,max-samples))
 727      ,@(when reset '((reset)))
 728      (start-profiling)
 729      (loop
 730         (when (>= *samples-index* (length *samples*))
 731           (return))
 732         ,@(when show-progress
 733             `((format t "~&===> ~d of ~d samples taken.~%"
 734                       (/ *samples-index* +sample-size+)
 735                       *max-samples*)))
 736         (let ((.last-index. *samples-index*))
 737           ,@body
 738           (when (= .last-index. *samples-index*)
 739             (warn "No sampling progress; possibly a profiler bug.")
 740             (return))))
 741      (stop-profiling)
 742      ,@(when report-p `((report :type ,report)))))
 743
 744 (defun start-profiling (&key (max-samples *max-samples*)
 745                         (sample-interval *sample-interval*)
 746                         (sampling t))
 747   "Start profiling statistically if not already profiling.
 748    The following keyword args are recognized:
 749
 750    :Sample-Interval <seconds>
 751      Take a sample every <seconds> seconds.  Default is
 752      *Sample-Interval*.
 753
 754    :Max-Samples <max>
 755      Maximum number of samples.  Default is *Max-Samples*.
 756
 757    :Sampling <bool>
 758      If true, the default, start sampling right away.
 759      If false, Start-Sampling can be used to turn sampling on."
 760   (unless *profiling*
 761     (multiple-value-bind (secs usecs)
 762         (multiple-value-bind (secs rest)
 763             (truncate sample-interval)
 764           (values secs (truncate (* rest 1000000))))
 765       (setq *samples* (make-array (* max-samples +sample-size+)
 766                                   :element-type 'address))
 767       (setq *samples-index* 0)
 768       (setq *sampling* sampling)
 769       ;; Disabled for now, since this was causing some problems with the
 770       ;; sampling getting turned off completely. --JES, 2004-06-19
 771       ;;
 772       ;; BEFORE-GC-HOOKS have exceedingly bad interactions with
 773       ;; threads.  -- CSR, 2004-06-21
 774       ;;
 775       ;; (pushnew 'turn-off-sampling *before-gc-hooks*)
 776       (pushnew 'adjust-samples-for-address-changes *after-gc-hooks*)
 777       (record-dyninfo)
 778       (sb-sys:enable-interrupt sb-unix:sigprof #'sigprof-handler)
 779       (unix-setitimer :profile secs usecs secs usecs)
 780       (setq *profiling* t)))
 781   (values))
 782
 783 (defun stop-profiling ()
 784   "Stop profiling if profiling."
 785   (when *profiling*
 786     (setq *after-gc-hooks*
 787           (delete 'adjust-samples-for-address-changes *after-gc-hooks*))
 788     (unix-setitimer :profile 0 0 0 0)
 789     ;; Even with the timer shut down we cannot be sure that there is
 790     ;; no undelivered sigprof. Besides, leaving the signal handler
 791     ;; installed won't hurt.
 792     (setq *sampling* nil)
 793     (setq *profiling* nil))
 794   (values))
 795
 796 (defun reset ()
 797   "Reset the profiler."
 798   (stop-profiling)
 799   (setq *sampling* nil)
 800   (setq *dynamic-space-code-info* ())
 801   (setq *samples* nil)
 802   (setq *samples-index* 0)
 803   (values))
 804
 805 ;;; Make a NODE for debug-info INFO.
 806 (defun make-node (info)
 807   (typecase info
 808     (sb-kernel::code-component
 809      (multiple-value-bind (start end)
 810          (code-bounds info)
 811        (%make-node :name (or (sb-disassem::find-assembler-routine start)
 812                              (format nil "~a" info))
 813                    :start-pc start :end-pc end)))
 814     (sb-di::compiled-debug-fun
 815      (let* ((name (sb-di::debug-fun-name info))
 816             (cdf (sb-di::compiled-debug-fun-compiler-debug-fun info))
 817             (start-offset (sb-c::compiled-debug-fun-start-pc cdf))
 818             (end-offset (sb-c::compiled-debug-fun-elsewhere-pc cdf))
 819             (component (sb-di::compiled-debug-fun-component info))
 820             (start-pc (code-start component)))
 821        ;; Call graphs are mostly useless unless we somehow
 822        ;; distinguish a gazillion different (LAMBDA ())'s.
 823        (when (equal name '(lambda ()))
 824          (setf name (format nil "Unknown component: #x~x" start-pc)))
 825        (%make-node :name name
 826                    :start-pc (+ start-pc start-offset)
 827                    :end-pc (+ start-pc end-offset))))
 828     (sb-di::debug-fun
 829      (%make-node :name (sb-di::debug-fun-name info)))
 830     (t
 831      (%make-node :name (coerce info 'string)))))
 832
 833 ;;; Return something serving as debug info for address PC.  If we can
 834 ;;; get something from SB-DI:DEBUG-FUNCTION-FROM-PC, return that.
 835 ;;; Otherwise, if we can determine a code component, return that.
 836 ;;; Otherwise return nil.
 837 (defun debug-info (pc)
 838   (declare (type address pc))
 839   (let ((ptr (sb-di::component-ptr-from-pc (int-sap pc))))
 840     (cond ((sap= ptr (int-sap 0))
 841            (let ((name (sap-foreign-symbol (int-sap pc))))
 842              (when name
 843                (format nil "foreign function ~a" name))))
 844           (t
 845            (let* ((code (sb-di::component-from-component-ptr ptr))
 846                   (code-header-len (* (sb-kernel:get-header-data code)
 847                                       sb-vm:n-word-bytes))
 848                   (pc-offset (- pc
 849                                 (- (sb-kernel:get-lisp-obj-address code)
 850                                    sb-vm:other-pointer-lowtag)
 851                                 code-header-len))
 852                   (df (ignore-errors (sb-di::debug-fun-from-pc code
 853                                                                pc-offset))))
 854              (or df
 855                  code))))))
 856
 857
 858 ;;; One function can have more than one COMPILED-DEBUG-FUNCTION with
 859 ;;; the same name.  Reduce the number of calls to Debug-Info by first
 860 ;;; looking for a given PC in a red-black tree.  If not found in the
 861 ;;; tree, get debug info, and look for a node in a hash-table by
 862 ;;; function name.  If not found in the hash-table, make a new node.
 863
 864 (defvar *node-tree*)
 865 (defvar *name->node*)
 866
 867 (defmacro with-lookup-tables (() &body body)
 868   `(let ((*node-tree* (make-aa-tree))
 869          (*name->node* (make-hash-table :test 'equal)))
 870      ,@body))
 871
 872 (defun tree-find (item)
 873   (flet ((pc/node-= (pc node)
 874            (<= (node-start-pc node) pc (node-end-pc node)))
 875          (pc/node-< (pc node)
 876            (< pc (node-start-pc node))))
 877     (aa-find item *node-tree* :test-= #'pc/node-= :test-< #'pc/node-<)))
 878
 879 (defun tree-insert (item)
 880   (flet ((node/node-= (x y)
 881            (<= (node-start-pc y) (node-start-pc x) (node-end-pc y)))
 882          (node/node-< (x y)
 883            (< (node-start-pc x) (node-start-pc y))))
 884     (aa-insert item *node-tree* :test-= #'node/node-= :test-< #'node/node-<)))
 885
 886 ;;; Find or make a new node for address PC.  Value is the NODE found
 887 ;;; or made; NIL if not enough information exists to make a NODE for
 888 ;;; PC.
 889 (defun lookup-node (pc)
 890   (declare (type address pc))
 891   (or (tree-find pc)
 892       (let ((info (debug-info pc)))
 893         (when info
 894           (let* ((new (make-node info))
 895                  (key (cons (node-name new)
 896                             (node-start-pc new)))
 897                  (found (gethash key *name->node*)))
 898             (cond (found
 899                    (setf (node-start-pc found)
 900                          (min (node-start-pc found) (node-start-pc new)))
 901                    (setf (node-end-pc found)
 902                          (max (node-end-pc found) (node-end-pc new)))
 903                    found)
 904                   (t
 905                    (setf (gethash key *name->node*) new)
 906                    (tree-insert new)
 907                    new)))))))
 908
 909 ;;; Return a list of all nodes created by LOOKUP-NODE.
 910 (defun collect-nodes ()
 911   (loop for node being the hash-values of *name->node*
 912         collect node))
 913
 914 ;;; Value is a CALL-GRAPH for the current contents of *SAMPLES*.
 915 (defun make-call-graph-1 (depth)
 916   (let ((elsewhere-count 0)
 917         visited-nodes)
 918     (with-lookup-tables ()
 919       (loop for i below (1- *samples-index*) ;; by +sample-size+
 920             as pc = (aref *samples* i)
 921             as return-pc = (aref *samples* (1+ i))
 922             as callee = (lookup-node pc)
 923             as caller =
 924               (when (and callee (/= return-pc +unknown-address+))
 925                 (let ((caller (lookup-node return-pc)))
 926                   (when caller
 927                     caller)))
 928             do
 929             (when (and *show-progress* (plusp i))
 930               (cond ((zerop (mod i 1000))
 931                      (show-progress "~d" i))
 932                     ((zerop (mod i 100))
 933                      (show-progress "."))))
 934             (when (< (mod i +sample-size+) depth)
 935               (when (= (mod i +sample-size+) 0)
 936                 (setf visited-nodes nil)
 937                 (cond (callee
 938                        (incf (node-accrued-count callee))
 939                        (incf (node-count callee)))
 940                       (t
 941                        (incf elsewhere-count))))
 942               (when callee
 943                 (push callee visited-nodes))
 944               (when caller
 945                 (unless (member caller visited-nodes)
 946                   (incf (node-accrued-count caller)))
 947                 (when callee
 948                   (let ((call (find callee (node-edges caller)
 949                                     :key #'call-vertex)))
 950                     (pushnew caller (node-callers callee))
 951                     (if call
 952                         (unless (member caller visited-nodes)
 953                           (incf (call-count call)))
 954                         (push (make-call callee) (node-edges caller))))))))
 955       (let ((sorted-nodes (sort (collect-nodes) #'> :key #'node-count)))
 956         (loop for node in sorted-nodes and i from 1 do
 957                 (setf (node-index node) i))
 958         (%make-call-graph :nsamples (/ *samples-index* +sample-size+)
 959                           :sample-interval *sample-interval*
 960                           :elsewhere-count elsewhere-count
 961                           :vertices sorted-nodes)))))
 962
 963 ;;; Reduce CALL-GRAPH to a dag, creating CYCLE structures for call
 964 ;;; cycles.
 965 (defun reduce-call-graph (call-graph)
 966   (let ((cycle-no 0))
 967     (flet ((make-one-cycle (vertices edges)
 968              (let* ((name (format nil "<Cycle ~d>" (incf cycle-no)))
 969                     (count (loop for v in vertices sum (node-count v))))
 970                (make-cycle :name name
 971                            :index cycle-no
 972                            :count count
 973                            :scc-vertices vertices
 974                            :edges edges))))
 975       (reduce-graph call-graph #'make-one-cycle))))
 976
 977 ;;; For all nodes in CALL-GRAPH, compute times including the time
 978 ;;; spent in functions called from them.  Note that the call-graph
 979 ;;; vertices are in reverse topological order, children first, so we
 980 ;;; will have computed accrued counts of called functions before they
 981 ;;; are used to compute accrued counts for callers.
 982 (defun compute-accrued-counts (call-graph)
 983   (do-vertices (from call-graph)
 984     (setf (node-accrued-count from) (node-count from))
 985     (do-edges (call to from)
 986       (incf (node-accrued-count from)
 987             (round (* (/ (call-count call) (node-count to))
 988                       (node-accrued-count to)))))))
 989
 990 ;;; Return a CALL-GRAPH structure for the current contents of
 991 ;;; *SAMPLES*.  The result contain a list of nodes sorted by self-time
 992 ;;; in the FLAT-NODES slot, and a dag in VERTICES, with call cycles
 993 ;;; reduced to CYCLE structures.
 994 (defun make-call-graph (depth)
 995   (stop-profiling)
 996   (show-progress "~&Computing call graph ")
 997   (let ((call-graph (without-gcing (make-call-graph-1 depth))))
 998     (setf (call-graph-flat-nodes call-graph)
 999           (copy-list (graph-vertices call-graph)))
1000     (show-progress "~&Finding cycles")
1001     (reduce-call-graph call-graph)
1002     (show-progress "~&Propagating counts")
1003     #+nil (compute-accrued-counts call-graph)
1004     call-graph))
1005
1006 \f
1007 ;;;; Reporting
1008
1009 (defun print-separator (&key (length 72) (char #\-))
1010   (format t "~&~V,,,V<~>~%" length char))
1011
1012 (defun samples-percent (call-graph count)
1013   (if (> count 0)
1014       (* 100.0 (/ count (call-graph-nsamples call-graph)))
1015       0))
1016
1017 (defun print-call-graph-header (call-graph)
1018   (let ((nsamples (call-graph-nsamples call-graph))
1019         (interval (call-graph-sample-interval call-graph))
1020         (ncycles (loop for v in (graph-vertices call-graph)
1021                        count (scc-p v))))
1022     (format t "~2&Number of samples:   ~d~%~
1023                   Sample interval:     ~f seconds~%~
1024                   Total sampling time: ~f seconds~%~
1025                   Number of cycles:    ~d~2%"
1026             nsamples
1027             interval
1028             (* nsamples interval)
1029             ncycles)))
1030
1031 (defun print-flat (call-graph &key (stream *standard-output*) max
1032                    min-percent (print-header t))
1033   (let ((*standard-output* stream)
1034         (*print-pretty* nil)
1035         (total-count 0)
1036         (total-percent 0)
1037         (min-count (if min-percent
1038                        (round (* (/ min-percent 100.0)
1039                                  (call-graph-nsamples call-graph)))
1040                        0)))
1041     (when print-header
1042       (print-call-graph-header call-graph))
1043     (format t "~&           Self        Cumul        Total~%")
1044     (format t "~&  Nr  Count     %  Count     %  Count     % Function~%")
1045     (print-separator)
1046     (let ((elsewhere-count (call-graph-elsewhere-count call-graph))
1047           (i 0))
1048       (dolist (node (call-graph-flat-nodes call-graph))
1049         (when (or (and max (> (incf i) max))
1050                   (< (node-count node) min-count))
1051           (return))
1052         (let* ((count (node-count node))
1053                (percent (samples-percent call-graph count))
1054                (accrued-count (node-accrued-count node))
1055                (accrued-percent (samples-percent call-graph accrued-count)))
1056           (incf total-count count)
1057           (incf total-percent percent)
1058           (format t "~&~4d ~6d ~5,1f ~6d ~5,1f ~6d ~5,1f ~s~%"
1059                   (node-index node)
1060                   count
1061                   percent
1062                   accrued-count
1063                   accrued-percent
1064                   total-count
1065                   total-percent
1066                   (node-name node))
1067           (finish-output)))
1068       (print-separator)
1069       (format t "~&    ~6d ~5,1f              elsewhere~%"
1070               elsewhere-count
1071               (samples-percent call-graph elsewhere-count)))))
1072
1073 (defun print-cycles (call-graph)
1074   (when (some #'cycle-p (graph-vertices call-graph))
1075     (format t "~&                            Cycle~%")
1076     (format t "~& Count     %                   Parts~%")
1077     (do-vertices (node call-graph)
1078       (when (cycle-p node)
1079         (flet ((print-info (indent index count percent name)
1080                  (format t "~&~6d ~5,1f ~11@t ~V@t  ~s [~d]~%"
1081                          count percent indent name index)))
1082           (print-separator)
1083           (format t "~&~6d ~5,1f                ~a...~%"
1084                   (node-count node)
1085                   (samples-percent call-graph (cycle-count node))
1086                   (node-name node))
1087           (dolist (v (vertex-scc-vertices node))
1088             (print-info 4 (node-index v) (node-count v)
1089                         (samples-percent call-graph (node-count v))
1090                         (node-name v))))))
1091     (print-separator)
1092     (format t "~2%")))
1093
1094 (defun print-graph (call-graph &key (stream *standard-output*)
1095                     max min-percent)
1096   (let ((*standard-output* stream)
1097         (*print-pretty* nil))
1098     (print-call-graph-header call-graph)
1099     (print-cycles call-graph)
1100     (flet ((find-call (from to)
1101              (find to (node-edges from) :key #'call-vertex))
1102            (print-info (indent index count percent name)
1103              (format t "~&~6d ~5,1f ~11@t ~V@t  ~s [~d]~%"
1104                      count percent indent name index)))
1105       (format t "~&                               Callers~%")
1106       (format t "~&                 Cumul.     Function~%")
1107       (format t "~& Count     %  Count     %      Callees~%")
1108       (do-vertices (node call-graph)
1109         (print-separator)
1110         ;;
1111         ;; Print caller information.
1112         (dolist (caller (node-callers node))
1113           (let ((call (find-call caller node)))
1114             (print-info 4 (node-index caller)
1115                         (call-count call)
1116                         (samples-percent call-graph (call-count call))
1117                         (node-name caller))))
1118         ;; Print the node itself.
1119         (format t "~&~6d ~5,1f ~6d ~5,1f   ~s [~d]~%"
1120                 (node-count node)
1121                 (samples-percent call-graph (node-count node))
1122                 (node-accrued-count node)
1123                 (samples-percent call-graph (node-accrued-count node))
1124                 (node-name node)
1125                 (node-index node))
1126         ;; Print callees.
1127         (do-edges (call called node)
1128           (print-info 4 (node-index called)
1129                       (call-count call)
1130                       (samples-percent call-graph (call-count call))
1131                       (node-name called))))
1132       (print-separator)
1133       (format t "~2%")
1134       (print-flat call-graph :stream stream :max max
1135                   :min-percent min-percent :print-header nil))))
1136
1137 (defun report (&key (type :graph) max min-percent call-graph
1138                (stream *standard-output*) ((:show-progress *show-progress*)))
1139   "Report statistical profiling results.  The following keyword
1140    args are recognized:
1141
1142    :Type <type>
1143       Specifies the type of report to generate.  If :FLAT, show
1144       flat report, if :GRAPH show a call graph and a flat report.
1145       If nil, don't print out a report.
1146
1147    :Stream <stream>
1148       Specify a stream to print the report on.  Default is
1149       *Standard-Output*.
1150
1151    :Max <max>
1152       Don't show more than <max> entries in the flat report.
1153
1154    :Min-Percent <min-percent>
1155       Don't show functions taking less than <min-percent> of the
1156       total time in the flat report.
1157
1158    :Show-Progress <bool>
1159      If true, print progress messages while generating the call graph.
1160
1161    :Call-Graph <graph>
1162      Print a report from <graph> instead of the latest profiling
1163      results.
1164
1165    Value of this function is a Call-Graph object representing the
1166    resulting call-graph."
1167   (let ((graph (or call-graph (make-call-graph (1- +sample-size+)))))
1168     (ecase type
1169       (:flat
1170        (print-flat graph :stream stream :max max :min-percent min-percent))
1171       (:graph
1172        (print-graph graph :stream stream :max max :min-percent min-percent))
1173       ((nil)))
1174     graph))
1175
1176 ;;; Interface to DISASSEMBLE
1177
1178 (defun add-disassembly-profile-note (chunk stream dstate)
1179   (declare (ignore chunk stream))
1180   (unless (zerop *samples-index*)
1181     (let* ((location
1182             (+ (sb-disassem::seg-virtual-location
1183                 (sb-disassem:dstate-segment dstate))
1184                (sb-disassem::dstate-cur-offs dstate)))
1185            (samples (loop for x from 0 below *samples-index* by +sample-size+
1186                           summing (if (= (aref *samples* x) location)
1187                                       1
1188                                       0))))
1189       (unless (zerop samples)
1190         (sb-disassem::note (format nil "~A/~A samples"
1191                                    samples (/ *samples-index* +sample-size+))
1192                            dstate)))))
1193
1194 (pushnew 'add-disassembly-profile-note sb-disassem::*default-dstate-hooks*)
1195
1196 ;;; silly examples
1197
1198 (defun test-0 (n &optional (depth 0))
1199   (declare (optimize (debug 3)))
1200   (when (< depth n)
1201     (dotimes (i n)
1202       (test-0 n (1+ depth))
1203       (test-0 n (1+ depth)))))
1204
1205 (defun test ()
1206   (with-profiling (:reset t :max-samples 1000 :report :graph)
1207     (test-0 7)))
1208
1209
1210 ;;; provision
1211 (provide 'sb-sprof)
1212
1213 ;;; end of file