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 \f
 233 ;;;; The Profiler
 234
 235 (deftype address ()
 236   "Type used for addresses, for instance, program counters,
 237    code start/end locations etc."
 238   '(unsigned-byte #.sb-vm::n-machine-word-bits))
 239
 240 (defconstant +unknown-address+ 0
 241   "Constant representing an address that cannot be determined.")
 242
 243 ;;; A call graph.  Vertices are NODE structures, edges are CALL
 244 ;;; structures.
 245 (defstruct (call-graph (:include graph)
 246                        (:constructor %make-call-graph))
 247   ;; the value of *Sample-Interval* at the time the graph was created
 248   (sample-interval (sb-impl::missing-arg) :type number)
 249   ;; number of samples taken
 250   (nsamples (sb-impl::missing-arg) :type sb-impl::index)
 251   ;; sample count for samples not in any function
 252   (elsewhere-count (sb-impl::missing-arg) :type sb-impl::index)
 253   ;; a flat list of NODEs, sorted by sample count
 254   (flat-nodes () :type list))
 255
 256 ;;; A node in a call graph, representing a function that has been
 257 ;;; sampled.  The edges of a node are CALL structures that represent
 258 ;;; functions called from a given node.
 259 (defstruct (node (:include vertex)
 260                  (:constructor %make-node))
 261   ;; A numeric label for the node.  The most frequently called function
 262   ;; gets label 1.  This is just for identification purposes in the
 263   ;; profiling report.
 264   (index 0 :type fixnum)
 265   ;; start and end address of the function's code
 266   (start-pc 0 :type address)
 267   (end-pc 0 :type address)
 268   ;; the name of the function
 269   (name nil :type t)
 270   ;; sample count for this function
 271   (count 0 :type fixnum)
 272   ;; count including time spent in functions called from this one
 273   (accrued-count 0 :type fixnum)
 274   ;; list of NODEs for functions calling this one
 275   (callers () :type list))
 276
 277 ;;; A cycle in a call graph.  The functions forming the cycle are
 278 ;;; found in the SCC-VERTICES slot of the VERTEX structure.
 279 (defstruct (cycle (:include node)))
 280
 281 ;;; An edge in a call graph.  EDGE-VERTEX is the function being
 282 ;;; called.
 283 (defstruct (call (:include edge)
 284                  (:constructor make-call (vertex)))
 285   ;; number of times the call was sampled
 286   (count 1 :type sb-impl::index))
 287
 288 ;;; Info about a function in dynamic-space.  This is used to track
 289 ;;; address changes of functions during GC.
 290 (defstruct (dyninfo (:constructor make-dyninfo (code start end)))
 291   ;; component this info is for
 292   (code (sb-impl::missing-arg) :type sb-kernel::code-component)
 293   ;; current start and end address of the component
 294   (start (sb-impl::missing-arg) :type address)
 295   (end (sb-impl::missing-arg) :type address)
 296   ;; new start address of the component, after GC.
 297   (new-start 0 :type address))
 298
 299 (defmethod print-object ((call-graph call-graph) stream)
 300   (print-unreadable-object (call-graph stream :type t :identity t)
 301     (format stream "~d samples" (call-graph-nsamples call-graph))))
 302
 303 (defmethod print-object ((node node) stream)
 304   (print-unreadable-object (node stream :type t :identity t)
 305     (format stream "~s [~d]" (node-name node) (node-index node))))
 306
 307 (defmethod print-object ((call call) stream)
 308   (print-unreadable-object (call stream :type t :identity t)
 309     (format stream "~s [~d]" (node-name (call-vertex call))
 310             (node-index (call-vertex call)))))
 311
 312 (deftype report-type ()
 313   '(member nil :flat :graph))
 314
 315 (defvar *sample-interval* 0.01
 316   "Default number of seconds between samples.")
 317 (declaim (number *sample-interval*))
 318
 319 (defvar *max-samples* 50000
 320   "Default number of samples taken.")
 321 (declaim (type sb-impl::index *max-samples*))
 322
 323 ;; For every profiler event we store this many samples (frames 0-n on
 324 ;; the call stack).
 325 (defconstant +sample-depth+
 326   #+(or x86 x86-64) 8
 327   #-(or x86 x86-64) 2)
 328
 329 ;; We store two elements for each sample. The debug-info of the sample
 330 ;; and either its absolute PC or a PC offset, depending on the type of
 331 ;; the debug-info.
 332 (defconstant +sample-size+ (* +sample-depth+ 2))
 333
 334 (defvar *samples* nil)
 335 (declaim (type (or null simple-vector) *samples*))
 336
 337 (defvar *samples-index* 0)
 338 (declaim (type sb-impl::index *samples-index*))
 339
 340 (defvar *profiling* nil)
 341 (defvar *sampling* nil)
 342 (declaim (type boolean *profiling* *sampling*))
 343
 344 (defvar *show-progress* nil)
 345
 346 (defvar *old-sampling* nil)
 347
 348 (defun turn-off-sampling ()
 349   (setq *old-sampling* *sampling*)
 350   (setq *sampling* nil))
 351
 352 (defun turn-on-sampling ()
 353   (setq *sampling* *old-sampling*))
 354
 355 (defun show-progress (format-string &rest args)
 356   (when *show-progress*
 357     (apply #'format t format-string args)
 358     (finish-output)))
 359
 360 (defun start-sampling ()
 361   "Switch on statistical sampling."
 362   (setq *sampling* t))
 363
 364 (defun stop-sampling ()
 365   "Switch off statistical sampling."
 366   (setq *sampling* nil))
 367
 368 (defmacro with-sampling ((&optional (on t)) &body body)
 369   "Evaluate body with statistical sampling turned on or off."
 370   `(let ((*sampling* ,on))
 371      ,@body))
 372
 373 ;;; Return something serving as debug info for address PC.
 374 (declaim (inline debug-info))
 375 (defun debug-info (pc)
 376   (declare (type system-area-pointer pc))
 377   (let ((ptr (sb-di::component-ptr-from-pc pc)))
 378     (cond ((sap= ptr (int-sap 0))
 379            (let ((name (sap-foreign-symbol pc)))
 380              (if name
 381                  (values (format nil "foreign function ~a" name)
 382                          (sap-int pc))
 383                  (values nil (sap-int pc)))))
 384           (t
 385            (let* ((code (sb-di::component-from-component-ptr ptr))
 386                   (code-header-len (* (sb-kernel:get-header-data code)
 387                                       sb-vm:n-word-bytes))
 388                   (pc-offset (- (sap-int pc)
 389                                 (- (sb-kernel:get-lisp-obj-address code)
 390                                    sb-vm:other-pointer-lowtag)
 391                                 code-header-len))
 392                   (df (sb-di::debug-fun-from-pc code pc-offset)))
 393              (cond ((typep df 'sb-di::bogus-debug-fun)
 394                     (values code (sap-int pc)))
 395                    (df
 396                     ;; The code component might be moved by the GC. Store
 397                     ;; a PC offset, and reconstruct the data in
 398                     ;; SAMPLE-PC-FROM-PC-OR-OFFSET.
 399                     (values df pc-offset))
 400                    (t
 401                     (values nil 0))))))))
 402
 403 (declaim (inline record))
 404 (defun record (pc)
 405   (declare (type system-area-pointer pc))
 406   (multiple-value-bind (info pc-or-offset)
 407       (debug-info pc)
 408     ;; For each sample, store the debug-info and the PC/offset into
 409     ;; adjacent cells.
 410     (setf (aref *samples* *samples-index*) info
 411           (aref *samples* (1+ *samples-index*)) pc-or-offset))
 412   (incf *samples-index* 2))
 413
 414 ;;; Ensure that only one thread at a time will be executing sigprof handler.
 415 (defvar *sigprof-handler-lock* (sb-thread:make-mutex :name "SIGPROF handler"))
 416
 417 ;;; SIGPROF handler.  Record current PC and return address in
 418 ;;; *SAMPLES*.
 419 #+(or x86 x86-64)
 420 (defun sigprof-handler (signal code scp)
 421   (declare (ignore signal code)
 422            (optimize speed (space 0))
 423            (type system-area-pointer scp))
 424   (sb-sys:without-interrupts
 425     (when (and *sampling*
 426                *samples*
 427                (< *samples-index* (length (the simple-vector *samples*))))
 428       (sb-sys:without-gcing
 429         (sb-thread:with-mutex (*sigprof-handler-lock*)
 430           (with-alien ((scp (* os-context-t) :local scp))
 431             (let* ((pc-ptr (sb-vm:context-pc scp))
 432                    (fp (sb-vm::context-register scp #.sb-vm::ebp-offset)))
 433               ;; For some reason completely bogus small values for the
 434               ;; frame pointer are returned every now and then, leading
 435               ;; to segfaults. Try to avoid these cases.
 436               ;;
 437               ;; FIXME: Do a more thorough sanity check on ebp, or figure
 438               ;; out why this is happening.
 439               ;; -- JES, 2005-01-11
 440               (when (< fp 4096)
 441                 (dotimes (i +sample-depth+)
 442                   (record (int-sap 0)))
 443                 (return-from sigprof-handler nil))
 444               (let ((fp (int-sap fp))
 445                     (ok t))
 446                 (declare (type system-area-pointer fp pc-ptr))
 447                 (dotimes (i +sample-depth+)
 448                   (record pc-ptr)
 449                   (when ok
 450                     (setf (values ok pc-ptr fp)
 451                           (sb-di::x86-call-context fp)))))))))))
 452   nil)
 453
 454 ;; FIXME: On non-x86 platforms we don't yet walk the call stack deeper
 455 ;; than one level.
 456 #-(or x86 x86-64)
 457 (defun sigprof-handler (signal code scp)
 458   (declare (ignore signal code))
 459   (sb-sys:without-interrupts
 460     (when (and *sampling*
 461                (< *samples-index* (length *samples*)))
 462       (sb-sys:without-gcing
 463         (with-alien ((scp (* os-context-t) :local scp))
 464           (locally (declare (optimize (inhibit-warnings 2)))
 465             (let* ((pc-ptr (sb-vm:context-pc scp))
 466                    (fp (sb-vm::context-register scp #.sb-vm::cfp-offset))
 467                    (ra (sap-ref-word
 468                         (int-sap fp)
 469                         (* sb-vm::lra-save-offset sb-vm::n-word-bytes))))
 470               (record pc-ptr)
 471               (record (int-sap ra)))))))))
 472
 473 ;;; Return the start address of CODE.
 474 (defun code-start (code)
 475   (declare (type sb-kernel:code-component code))
 476   (sap-int (sb-kernel:code-instructions code)))
 477
 478 ;;; Return start and end address of CODE as multiple values.
 479 (defun code-bounds (code)
 480   (declare (type sb-kernel:code-component code))
 481   (let* ((start (code-start code))
 482          (end (+ start (sb-kernel:%code-code-size code))))
 483     (values start end)))
 484
 485 (defmacro with-profiling ((&key (sample-interval '*sample-interval*)
 486                                 (max-samples '*max-samples*)
 487                                 (reset nil)
 488                                 show-progress
 489                                 (report nil report-p))
 490                           &body body)
 491   "Repeatedly evaluate Body with statistical profiling turned on.
 492    The following keyword args are recognized:
 493
 494    :Sample-Interval <seconds>
 495      Take a sample every <seconds> seconds.  Default is
 496      *Sample-Interval*.
 497
 498    :Max-Samples <max>
 499      Repeat evaluating body until <max> samples are taken.
 500      Default is *Max-Samples*.
 501
 502    :Report <type>
 503      If specified, call Report with :Type <type> at the end.
 504
 505    :Reset <bool>
 506      It true, call Reset at the beginning."
 507   (declare (type report-type report))
 508   `(let ((*sample-interval* ,sample-interval)
 509          (*max-samples* ,max-samples))
 510      ,@(when reset '((reset)))
 511      (unwind-protect
 512           (progn
 513             (start-profiling)
 514             (loop
 515                (when (>= *samples-index* (length *samples*))
 516                  (return))
 517                ,@(when show-progress
 518                        `((format t "~&===> ~d of ~d samples taken.~%"
 519                                  (/ *samples-index* +sample-size+)
 520                                  *max-samples*)))
 521                (let ((.last-index. *samples-index*))
 522                  ,@body
 523                  (when (= .last-index. *samples-index*)
 524                    (warn "No sampling progress; possibly a profiler bug.")
 525                    (return)))))
 526        (stop-profiling))
 527      ,@(when report-p `((report :type ,report)))))
 528
 529 (defun start-profiling (&key (max-samples *max-samples*)
 530                         (sample-interval *sample-interval*)
 531                         (sampling t))
 532   "Start profiling statistically if not already profiling.
 533    The following keyword args are recognized:
 534
 535    :Sample-Interval <seconds>
 536      Take a sample every <seconds> seconds.  Default is
 537      *Sample-Interval*.
 538
 539    :Max-Samples <max>
 540      Maximum number of samples.  Default is *Max-Samples*.
 541
 542    :Sampling <bool>
 543      If true, the default, start sampling right away.
 544      If false, Start-Sampling can be used to turn sampling on."
 545   (unless *profiling*
 546     (multiple-value-bind (secs usecs)
 547         (multiple-value-bind (secs rest)
 548             (truncate sample-interval)
 549           (values secs (truncate (* rest 1000000))))
 550       (setq *samples* (make-array (* max-samples +sample-size+)))
 551       (setq *samples-index* 0)
 552       (setq *sampling* sampling)
 553       (sb-sys:enable-interrupt sb-unix:sigprof #'sigprof-handler)
 554       (unix-setitimer :profile secs usecs secs usecs)
 555       (setq *profiling* t)))
 556   (values))
 557
 558 (defun stop-profiling ()
 559   "Stop profiling if profiling."
 560   (when *profiling*
 561     (unix-setitimer :profile 0 0 0 0)
 562     ;; Even with the timer shut down we cannot be sure that there is
 563     ;; no undelivered sigprof. Besides, leaving the signal handler
 564     ;; installed won't hurt.
 565     (setq *sampling* nil)
 566     (setq *profiling* nil))
 567   (values))
 568
 569 (defun reset ()
 570   "Reset the profiler."
 571   (stop-profiling)
 572   (setq *sampling* nil)
 573   (setq *samples* nil)
 574   (setq *samples-index* 0)
 575   (values))
 576
 577 ;;; Make a NODE for debug-info INFO.
 578 (defun make-node (info)
 579   (flet ((clean-name (name)
 580            (if (and (consp name)
 581                     (member (first name)
 582                             '(sb-c::xep sb-c::tl-xep sb-c::&more-processor
 583                               sb-c::hairy-arg-processor
 584                               sb-c::&optional-processor)))
 585                (second name)
 586                name)))
 587     (typecase info
 588       (sb-kernel::code-component
 589        (multiple-value-bind (start end)
 590            (code-bounds info)
 591          (%make-node :name (or (sb-disassem::find-assembler-routine start)
 592                                (format nil "~a" info))
 593                      :start-pc start :end-pc end)))
 594       (sb-di::compiled-debug-fun
 595        (let* ((name (sb-di::debug-fun-name info))
 596               (cdf (sb-di::compiled-debug-fun-compiler-debug-fun info))
 597               (start-offset (sb-c::compiled-debug-fun-start-pc cdf))
 598               (end-offset (sb-c::compiled-debug-fun-elsewhere-pc cdf))
 599               (component (sb-di::compiled-debug-fun-component info))
 600               (start-pc (code-start component)))
 601          ;; Call graphs are mostly useless unless we somehow
 602          ;; distinguish a gazillion different (LAMBDA ())'s.
 603          (when (equal name '(lambda ()))
 604            (setf name (format nil "Unknown component: #x~x" start-pc)))
 605          (%make-node :name (clean-name name)
 606                      :start-pc (+ start-pc start-offset)
 607                      :end-pc (+ start-pc end-offset))))
 608       (sb-di::debug-fun
 609        (%make-node :name (clean-name (sb-di::debug-fun-name info))))
 610       (t
 611        (%make-node :name (coerce info 'string))))))
 612
 613 ;;; One function can have more than one COMPILED-DEBUG-FUNCTION with
 614 ;;; the same name.  Reduce the number of calls to Debug-Info by first
 615 ;;; looking for a given PC in a red-black tree.  If not found in the
 616 ;;; tree, get debug info, and look for a node in a hash-table by
 617 ;;; function name.  If not found in the hash-table, make a new node.
 618
 619 (defvar *name->node*)
 620
 621 (defmacro with-lookup-tables (() &body body)
 622   `(let ((*name->node* (make-hash-table :test 'equal)))
 623      ,@body))
 624
 625 ;;; Find or make a new node for address PC.  Value is the NODE found
 626 ;;; or made; NIL if not enough information exists to make a NODE for
 627 ;;; PC.
 628 (defun lookup-node (info)
 629   (when info
 630     (let* ((new (make-node info))
 631            (key (cons (node-name new)
 632                       (node-start-pc new)))
 633            (found (gethash key *name->node*)))
 634       (cond (found
 635              (setf (node-start-pc found)
 636                    (min (node-start-pc found) (node-start-pc new)))
 637              (setf (node-end-pc found)
 638                    (max (node-end-pc found) (node-end-pc new)))
 639              found)
 640             (t
 641              (setf (gethash key *name->node*) new)
 642              new)))))
 643
 644 ;;; Return a list of all nodes created by LOOKUP-NODE.
 645 (defun collect-nodes ()
 646   (loop for node being the hash-values of *name->node*
 647         collect node))
 648
 649 ;;; Value is a CALL-GRAPH for the current contents of *SAMPLES*.
 650 (defun make-call-graph-1 (depth)
 651   (let ((elsewhere-count 0)
 652         visited-nodes)
 653     (with-lookup-tables ()
 654       (loop for i below (- *samples-index* 2) by 2
 655             for callee = (lookup-node (aref *samples* i))
 656             for caller = (lookup-node (aref *samples* (+ i 2)))
 657             do
 658             (when (and *show-progress* (plusp i))
 659               (cond ((zerop (mod i 1000))
 660                      (show-progress "~d" i))
 661                     ((zerop (mod i 100))
 662                      (show-progress "."))))
 663             (when (< (mod i +sample-size+) depth)
 664               (when (= (mod i +sample-size+) 0)
 665                 (setf visited-nodes nil)
 666                 (cond (callee
 667                        (incf (node-accrued-count callee))
 668                        (incf (node-count callee)))
 669                       (t
 670                        (incf elsewhere-count))))
 671               (when callee
 672                 (push callee visited-nodes))
 673               (when caller
 674                 (unless (member caller visited-nodes)
 675                   (incf (node-accrued-count caller)))
 676                 (when callee
 677                   (let ((call (find callee (node-edges caller)
 678                                     :key #'call-vertex)))
 679                     (pushnew caller (node-callers callee))
 680                     (if call
 681                         (unless (member caller visited-nodes)
 682                           (incf (call-count call)))
 683                         (push (make-call callee) (node-edges caller))))))))
 684       (let ((sorted-nodes (sort (collect-nodes) #'> :key #'node-count)))
 685         (loop for node in sorted-nodes and i from 1 do
 686                 (setf (node-index node) i))
 687         (%make-call-graph :nsamples (/ *samples-index* +sample-size+)
 688                           :sample-interval *sample-interval*
 689                           :elsewhere-count elsewhere-count
 690                           :vertices sorted-nodes)))))
 691
 692 ;;; Reduce CALL-GRAPH to a dag, creating CYCLE structures for call
 693 ;;; cycles.
 694 (defun reduce-call-graph (call-graph)
 695   (let ((cycle-no 0))
 696     (flet ((make-one-cycle (vertices edges)
 697              (let* ((name (format nil "<Cycle ~d>" (incf cycle-no)))
 698                     (count (loop for v in vertices sum (node-count v))))
 699                (make-cycle :name name
 700                            :index cycle-no
 701                            :count count
 702                            :scc-vertices vertices
 703                            :edges edges))))
 704       (reduce-graph call-graph #'make-one-cycle))))
 705
 706 ;;; For all nodes in CALL-GRAPH, compute times including the time
 707 ;;; spent in functions called from them.  Note that the call-graph
 708 ;;; vertices are in reverse topological order, children first, so we
 709 ;;; will have computed accrued counts of called functions before they
 710 ;;; are used to compute accrued counts for callers.
 711 (defun compute-accrued-counts (call-graph)
 712   (do-vertices (from call-graph)
 713     (setf (node-accrued-count from) (node-count from))
 714     (do-edges (call to from)
 715       (incf (node-accrued-count from)
 716             (round (* (/ (call-count call) (node-count to))
 717                       (node-accrued-count to)))))))
 718
 719 ;;; Return a CALL-GRAPH structure for the current contents of
 720 ;;; *SAMPLES*.  The result contain a list of nodes sorted by self-time
 721 ;;; in the FLAT-NODES slot, and a dag in VERTICES, with call cycles
 722 ;;; reduced to CYCLE structures.
 723 (defun make-call-graph (depth)
 724   (stop-profiling)
 725   (show-progress "~&Computing call graph ")
 726   (let ((call-graph (without-gcing (make-call-graph-1 depth))))
 727     (setf (call-graph-flat-nodes call-graph)
 728           (copy-list (graph-vertices call-graph)))
 729     (show-progress "~&Finding cycles")
 730     (reduce-call-graph call-graph)
 731     (show-progress "~&Propagating counts")
 732     #+nil (compute-accrued-counts call-graph)
 733     call-graph))
 734
 735 \f
 736 ;;;; Reporting
 737
 738 (defun print-separator (&key (length 72) (char #\-))
 739   (format t "~&~V,,,V<~>~%" length char))
 740
 741 (defun samples-percent (call-graph count)
 742   (if (> count 0)
 743       (* 100.0 (/ count (call-graph-nsamples call-graph)))
 744       0))
 745
 746 (defun print-call-graph-header (call-graph)
 747   (let ((nsamples (call-graph-nsamples call-graph))
 748         (interval (call-graph-sample-interval call-graph))
 749         (ncycles (loop for v in (graph-vertices call-graph)
 750                        count (scc-p v))))
 751     (format t "~2&Number of samples:   ~d~%~
 752                   Sample interval:     ~f seconds~%~
 753                   Total sampling time: ~f seconds~%~
 754                   Number of cycles:    ~d~2%"
 755             nsamples
 756             interval
 757             (* nsamples interval)
 758             ncycles)))
 759
 760 (defun print-flat (call-graph &key (stream *standard-output*) max
 761                    min-percent (print-header t))
 762   (let ((*standard-output* stream)
 763         (*print-pretty* nil)
 764         (total-count 0)
 765         (total-percent 0)
 766         (min-count (if min-percent
 767                        (round (* (/ min-percent 100.0)
 768                                  (call-graph-nsamples call-graph)))
 769                        0)))
 770     (when print-header
 771       (print-call-graph-header call-graph))
 772     (format t "~&           Self        Cumul        Total~%")
 773     (format t "~&  Nr  Count     %  Count     %  Count     % Function~%")
 774     (print-separator)
 775     (let ((elsewhere-count (call-graph-elsewhere-count call-graph))
 776           (i 0))
 777       (dolist (node (call-graph-flat-nodes call-graph))
 778         (when (or (and max (> (incf i) max))
 779                   (< (node-count node) min-count))
 780           (return))
 781         (let* ((count (node-count node))
 782                (percent (samples-percent call-graph count))
 783                (accrued-count (node-accrued-count node))
 784                (accrued-percent (samples-percent call-graph accrued-count)))
 785           (incf total-count count)
 786           (incf total-percent percent)
 787           (format t "~&~4d ~6d ~5,1f ~6d ~5,1f ~6d ~5,1f ~s~%"
 788                   (node-index node)
 789                   count
 790                   percent
 791                   accrued-count
 792                   accrued-percent
 793                   total-count
 794                   total-percent
 795                   (node-name node))
 796           (finish-output)))
 797       (print-separator)
 798       (format t "~&    ~6d ~5,1f              elsewhere~%"
 799               elsewhere-count
 800               (samples-percent call-graph elsewhere-count)))))
 801
 802 (defun print-cycles (call-graph)
 803   (when (some #'cycle-p (graph-vertices call-graph))
 804     (format t "~&                            Cycle~%")
 805     (format t "~& Count     %                   Parts~%")
 806     (do-vertices (node call-graph)
 807       (when (cycle-p node)
 808         (flet ((print-info (indent index count percent name)
 809                  (format t "~&~6d ~5,1f ~11@t ~V@t  ~s [~d]~%"
 810                          count percent indent name index)))
 811           (print-separator)
 812           (format t "~&~6d ~5,1f                ~a...~%"
 813                   (node-count node)
 814                   (samples-percent call-graph (cycle-count node))
 815                   (node-name node))
 816           (dolist (v (vertex-scc-vertices node))
 817             (print-info 4 (node-index v) (node-count v)
 818                         (samples-percent call-graph (node-count v))
 819                         (node-name v))))))
 820     (print-separator)
 821     (format t "~2%")))
 822
 823 (defun print-graph (call-graph &key (stream *standard-output*)
 824                     max min-percent)
 825   (let ((*standard-output* stream)
 826         (*print-pretty* nil))
 827     (print-call-graph-header call-graph)
 828     (print-cycles call-graph)
 829     (flet ((find-call (from to)
 830              (find to (node-edges from) :key #'call-vertex))
 831            (print-info (indent index count percent name)
 832              (format t "~&~6d ~5,1f ~11@t ~V@t  ~s [~d]~%"
 833                      count percent indent name index)))
 834       (format t "~&                               Callers~%")
 835       (format t "~&                 Cumul.     Function~%")
 836       (format t "~& Count     %  Count     %      Callees~%")
 837       (do-vertices (node call-graph)
 838         (print-separator)
 839         ;;
 840         ;; Print caller information.
 841         (dolist (caller (node-callers node))
 842           (let ((call (find-call caller node)))
 843             (print-info 4 (node-index caller)
 844                         (call-count call)
 845                         (samples-percent call-graph (call-count call))
 846                         (node-name caller))))
 847         ;; Print the node itself.
 848         (format t "~&~6d ~5,1f ~6d ~5,1f   ~s [~d]~%"
 849                 (node-count node)
 850                 (samples-percent call-graph (node-count node))
 851                 (node-accrued-count node)
 852                 (samples-percent call-graph (node-accrued-count node))
 853                 (node-name node)
 854                 (node-index node))
 855         ;; Print callees.
 856         (do-edges (call called node)
 857           (print-info 4 (node-index called)
 858                       (call-count call)
 859                       (samples-percent call-graph (call-count call))
 860                       (node-name called))))
 861       (print-separator)
 862       (format t "~2%")
 863       (print-flat call-graph :stream stream :max max
 864                   :min-percent min-percent :print-header nil))))
 865
 866 (defun report (&key (type :graph) max min-percent call-graph
 867                (stream *standard-output*) ((:show-progress *show-progress*)))
 868   "Report statistical profiling results.  The following keyword
 869    args are recognized:
 870
 871    :Type <type>
 872       Specifies the type of report to generate.  If :FLAT, show
 873       flat report, if :GRAPH show a call graph and a flat report.
 874       If nil, don't print out a report.
 875
 876    :Stream <stream>
 877       Specify a stream to print the report on.  Default is
 878       *Standard-Output*.
 879
 880    :Max <max>
 881       Don't show more than <max> entries in the flat report.
 882
 883    :Min-Percent <min-percent>
 884       Don't show functions taking less than <min-percent> of the
 885       total time in the flat report.
 886
 887    :Show-Progress <bool>
 888      If true, print progress messages while generating the call graph.
 889
 890    :Call-Graph <graph>
 891      Print a report from <graph> instead of the latest profiling
 892      results.
 893
 894    Value of this function is a Call-Graph object representing the
 895    resulting call-graph."
 896   (let ((graph (or call-graph (make-call-graph (1- +sample-depth+)))))
 897     (ecase type
 898       (:flat
 899        (print-flat graph :stream stream :max max :min-percent min-percent))
 900       (:graph
 901        (print-graph graph :stream stream :max max :min-percent min-percent))
 902       ((nil)))
 903     graph))
 904
 905 ;;; Interface to DISASSEMBLE
 906
 907 (defun sample-pc-from-pc-or-offset (sample pc-or-offset)
 908   (etypecase sample
 909     ;; Assembly routines or foreign functions don't move around, so we've
 910     ;; stored a raw PC
 911     ((or sb-kernel:code-component string)
 912      pc-or-offset)
 913     ;; Lisp functions might move, so we've stored a offset from the
 914     ;; start of the code component.
 915     (sb-di::compiled-debug-fun
 916      (let* ((component (sb-di::compiled-debug-fun-component sample))
 917             (start-pc (code-start component)))
 918        (+ start-pc pc-or-offset)))))
 919
 920 (defun add-disassembly-profile-note (chunk stream dstate)
 921   (declare (ignore chunk stream))
 922   (unless (zerop *samples-index*)
 923     (let* ((location
 924             (+ (sb-disassem::seg-virtual-location
 925                 (sb-disassem:dstate-segment dstate))
 926                (sb-disassem::dstate-cur-offs dstate)))
 927            (samples (loop for x from 0 below *samples-index* by +sample-size+
 928                           for sample = (aref *samples* x)
 929                           for pc-or-offset = (aref *samples* (1+ x))
 930                           count (= location
 931                                    (sample-pc-from-pc-or-offset sample
 932                                                                 pc-or-offset)))))
 933       (unless (zerop samples)
 934         (sb-disassem::note (format nil "~A/~A samples"
 935                                    samples (/ *samples-index* +sample-size+))
 936                            dstate)))))
 937
 938 (pushnew 'add-disassembly-profile-note sb-disassem::*default-dstate-hooks*)
 939
 940 ;;; silly examples
 941
 942 (defun test-0 (n &optional (depth 0))
 943   (declare (optimize (debug 3)))
 944   (when (< depth n)
 945     (dotimes (i n)
 946       (test-0 n (1+ depth))
 947       (test-0 n (1+ depth)))))
 948
 949 (defun test ()
 950   (with-profiling (:reset t :max-samples 1000 :report :graph)
 951     (test-0 7)))
 952
 953
 954 ;;; provision
 955 (provide 'sb-sprof)
 956
 957 ;;; end of file