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