src/code/profile.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was
   5 ;;;; written at Carnegie Mellon University and released into the
   6 ;;;; public domain. The software is in the public domain and is
   7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   8 ;;;; files for more information.
   9
  10 (in-package "SB-PROFILE") ; (SB-, not SB!, since we're built in warm load.)
  11 \f
  12
  13 ;;;; COUNTER object
  14 ;;;;
  15 ;;;; Thread safe, and reasonably fast: in common case increment is just an
  16 ;;;; ATOMIC-INCF, in overflow case grab a lock and increment overflow counter.
  17
  18 (defconstant +most-positive-word+ (1- (expt 2 sb-vm:n-word-bits)))
  19
  20 (declaim (inline make-counter))
  21 (defstruct (counter (:copier nil))
  22   (count 0 :type sb-vm:word)
  23   (overflow 0 :type unsigned-byte)
  24   (overflow-lock (sb-thread::make-spinlock) :type sb-thread::spinlock))
  25
  26 (defun incf-counter (counter delta)
  27   ;; When running multi-threaded we can easily get negative numbers for the
  28   ;; cons-counter. Don't count them at all.
  29   (when (plusp delta)
  30     ;; ATOMIC-INCF is restricted to signed-word, but delta can be bigger: first
  31     ;; count the number of full overflows...
  32     (loop while (>= delta +most-positive-word+)
  33           do (sb-thread::with-spinlock ((counter-overflow-lock counter))
  34                (incf (counter-overflow counter) 1))
  35           (decf delta +most-positive-word+))
  36     (flet ((%incf (d)
  37              (let ((prev (atomic-incf (counter-count counter) d)))
  38                (when (< (logand +most-positive-word+ (+ prev d)) prev)
  39                  (sb-thread::with-spinlock ((counter-overflow-lock counter))
  40                    (incf (counter-overflow counter)))))))
  41       (if (typep delta '(signed-byte 32))
  42           (%incf delta)
  43           ;; ...and if delta is still too big, split it into four parts: they
  44           ;; are guaranteed to fit into a signed word.
  45           (let ((quarter (truncate delta 4)))
  46             (%incf quarter)
  47             (%incf quarter)
  48             (%incf quarter)
  49             (%incf quarter)))))
  50   counter)
  51
  52 (defun counter->integer (counter)
  53   (+ (counter-count counter)
  54      (* (counter-overflow counter)
  55         +most-positive-word+)))
  56 \f
  57 ;;;; High resolution timer
  58
  59 ;;; FIXME: High resolution this is not. Build a microsecond-accuracy version
  60 ;;; on top of unix-getrusage, maybe.
  61
  62 (defconstant +ticks-per-second+ internal-time-units-per-second)
  63
  64 (declaim (inline get-internal-ticks))
  65 (defun get-internal-ticks ()
  66   (get-internal-run-time))
  67 \f
  68 ;;;; global data structures
  69
  70 ;;; We associate a PROFILE-INFO structure with each profiled function
  71 ;;; name. This holds the functions that we call to manipulate the
  72 ;;; closure which implements the encapsulation.
  73 (defvar *profiled-fun-name->info*
  74   (make-hash-table
  75    ;; EQL testing isn't good enough for generalized function names
  76    ;; like (SETF FOO).
  77    :test 'equal
  78    :synchronized t))
  79 (defstruct (profile-info (:copier nil))
  80   (name              (missing-arg) :read-only t)
  81   (encapsulated-fun  (missing-arg) :type function :read-only t)
  82   (encapsulation-fun (missing-arg) :type function :read-only t)
  83   (read-stats-fun    (missing-arg) :type function :read-only t)
  84   (clear-stats-fun   (missing-arg) :type function :read-only t))
  85
  86 ;;; These variables are used to subtract out the time and consing for
  87 ;;; recursive and other dynamically nested profiled calls. The total
  88 ;;; resource consumed for each nested call is added into the
  89 ;;; appropriate variable. When the outer function returns, these
  90 ;;; amounts are subtracted from the total.
  91 (declaim (counter *enclosed-ticks* *enclosed-consing*))
  92 (defvar *enclosed-ticks*)
  93 (defvar *enclosed-consing*)
  94
  95 ;;; This variable is also used to subtract out time for nested
  96 ;;; profiled calls. The time inside the profile wrapper call --
  97 ;;; between its two calls to GET-INTERNAL-TICKS -- is accounted
  98 ;;; for by the *ENCLOSED-TIME* variable. However, there's also extra
  99 ;;; overhead involved, before we get to the first call to
 100 ;;; GET-INTERNAL-TICKS, and after we get to the second call. By
 101 ;;; keeping track of the count of enclosed profiled calls, we can try
 102 ;;; to compensate for that.
 103 (declaim (counter *enclosed-profiles*))
 104 (defvar *enclosed-profiles*)
 105
 106 ;;; the encapsulated function we're currently computing profiling data
 107 ;;; for, recorded so that we can detect the problem of
 108 ;;; PROFILE-computing machinery calling a function which has itself
 109 ;;; been PROFILEd
 110 (defvar *computing-profiling-data-for*)
 111
 112 ;;; the components of profiling overhead
 113 (defstruct (overhead (:copier nil))
 114   ;; the number of ticks a bare function call takes. This is
 115   ;; factored into the other overheads, but not used for itself.
 116   (call (missing-arg) :type single-float :read-only t)
 117   ;; the number of ticks that will be charged to a profiled
 118   ;; function due to the profiling code
 119   (internal (missing-arg) :type single-float :read-only t)
 120   ;; the number of ticks of overhead for profiling that a single
 121   ;; profiled call adds to the total runtime for the program
 122   (total (missing-arg) :type single-float :read-only t))
 123 (defvar *overhead*)
 124 (declaim (type overhead *overhead*))
 125 (makunbound '*overhead*) ; in case we reload this file when tweaking
 126 \f
 127 ;;;; profile encapsulations
 128
 129 ;;; Return a collection of closures over the same lexical context,
 130 ;;;   (VALUES ENCAPSULATION-FUN READ-STATS-FUN CLEAR-STATS-FUN).
 131 ;;;
 132 ;;; ENCAPSULATION-FUN is a plug-in replacement for ENCAPSULATED-FUN,
 133 ;;; which updates statistics whenever it's called.
 134 ;;;
 135 ;;; READ-STATS-FUN returns the statistics:
 136 ;;;   (VALUES COUNT TIME CONSING PROFILE).
 137 ;;; COUNT is the count of calls to ENCAPSULATION-FUN. TICKS is
 138 ;;; the total number of ticks spent in ENCAPSULATED-FUN.
 139 ;;; CONSING is the total consing of ENCAPSULATION-FUN. PROFILE is the
 140 ;;; number of calls to the profiled function, stored for the purposes
 141 ;;; of trying to estimate that part of profiling overhead which occurs
 142 ;;; outside the interval between the profile wrapper function's timer
 143 ;;; calls.
 144 ;;;
 145 ;;; CLEAR-STATS-FUN clears the statistics.
 146 ;;;
 147 ;;; (The reason for implementing this as coupled closures, with the
 148 ;;; counts built into the lexical environment, is that we hope this
 149 ;;; will minimize profiling overhead.)
 150 (defun profile-encapsulation-lambdas (encapsulated-fun)
 151   (declare (type function encapsulated-fun))
 152   (let* ((count (make-counter))
 153          (ticks (make-counter))
 154          (consing (make-counter))
 155          (profiles (make-counter)))
 156     (declare (counter count ticks consing profiles))
 157     (values
 158      ;; ENCAPSULATION-FUN
 159      (lambda (&more arg-context arg-count)
 160        (declare (optimize speed safety))
 161        ;; Make sure that we're not recursing infinitely.
 162        (when (boundp '*computing-profiling-data-for*)
 163          (unprofile-all) ; to avoid further recursion
 164          (error "~@<When computing profiling data for ~S, the profiled ~
 165                     function ~S was called. To get out of this infinite recursion, all ~
 166                     functions have been unprofiled. (Since the profiling system evidently ~
 167                     uses ~S in its computations, it looks as though it's a bad idea to ~
 168                     profile it.)~:@>"
 169                 *computing-profiling-data-for* encapsulated-fun
 170                 encapsulated-fun))
 171        (incf-counter count 1)
 172        (let ((dticks 0)
 173              (dconsing 0)
 174              (inner-enclosed-profiles 0))
 175          (declare (truly-dynamic-extent dticks dconsing inner-enclosed-profiles))
 176          (unwind-protect
 177              (let* ((start-ticks (get-internal-ticks))
 178                     (*enclosed-ticks* (make-counter))
 179                     (*enclosed-consing* (make-counter))
 180                     (*enclosed-profiles* (make-counter))
 181                     (nbf0 *n-bytes-freed-or-purified*)
 182                     (dynamic-usage-0 (sb-kernel:dynamic-usage)))
 183                (declare (dynamic-extent *enclosed-ticks* *enclosed-consing* *enclosed-profiles*))
 184                (unwind-protect
 185                    (multiple-value-call encapsulated-fun
 186                                         (sb-c:%more-arg-values arg-context
 187                                                                0
 188                                                                arg-count))
 189                  (let ((*computing-profiling-data-for* encapsulated-fun)
 190                        (dynamic-usage-1 (sb-kernel:dynamic-usage)))
 191                    (setf dticks (- (get-internal-ticks) start-ticks)
 192                          dconsing (if (eql *n-bytes-freed-or-purified* nbf0)
 193                                       ;; common special case where we can avoid
 194                                       ;; bignum arithmetic
 195                                       (- dynamic-usage-1 dynamic-usage-0)
 196                                       ;; general case
 197                                       (- (get-bytes-consed) nbf0 dynamic-usage-0))
 198                          inner-enclosed-profiles (counter->integer *enclosed-profiles*))
 199                    (incf-counter ticks (- dticks (counter->integer *enclosed-ticks*)))
 200                    (incf-counter consing (- dconsing (counter->integer *enclosed-consing*)))
 201                    (incf-counter profiles inner-enclosed-profiles))))
 202            (when (boundp '*enclosed-ticks*)
 203              (incf-counter *enclosed-ticks* dticks)
 204              (incf-counter *enclosed-consing* dconsing)
 205              (incf-counter *enclosed-profiles* (1+ inner-enclosed-profiles))))))
 206      ;; READ-STATS-FUN
 207      (lambda ()
 208        (values (counter->integer count)
 209                (counter->integer ticks)
 210                (counter->integer consing)
 211                (counter->integer profiles)))
 212      ;; CLEAR-STATS-FUN
 213      (lambda ()
 214        (setf count (make-counter)
 215              ticks (make-counter)
 216              consing (make-counter)
 217              profiles (make-counter))))))
 218 \f
 219 ;;;; interfaces
 220
 221 ;;; A symbol or (SETF FOO) list names a function, a string names all
 222 ;;; the functions named by symbols in the named package.
 223 (defun mapc-on-named-funs (function names)
 224   (dolist (name names)
 225     (etypecase name
 226       (symbol (funcall function name))
 227       (list
 228        (legal-fun-name-or-type-error name)
 229        ;; Then we map onto it.
 230        (funcall function name))
 231       (string (let ((package (find-undeleted-package-or-lose name)))
 232                 (do-symbols (symbol package)
 233                   (when (eq (symbol-package symbol) package)
 234                     (when (and (fboundp symbol)
 235                                (not (macro-function symbol))
 236                                (not (special-operator-p symbol)))
 237                       (funcall function symbol))
 238                     (let ((setf-name `(setf ,symbol)))
 239                       (when (fboundp setf-name)
 240                         (funcall function setf-name)))))))))
 241   (values))
 242
 243 ;;; Profile the named function, which should exist and not be profiled
 244 ;;; already.
 245 (defun profile-1-unprofiled-fun (name)
 246   (let ((encapsulated-fun (fdefinition name)))
 247     (multiple-value-bind (encapsulation-fun read-stats-fun clear-stats-fun)
 248         (profile-encapsulation-lambdas encapsulated-fun)
 249       (without-package-locks
 250        (setf (fdefinition name)
 251              encapsulation-fun))
 252       (setf (gethash name *profiled-fun-name->info*)
 253             (make-profile-info :name name
 254                                :encapsulated-fun encapsulated-fun
 255                                :encapsulation-fun encapsulation-fun
 256                                :read-stats-fun read-stats-fun
 257                                :clear-stats-fun clear-stats-fun))
 258       (values))))
 259
 260 ;;; Profile the named function. If already profiled, unprofile first.
 261 (defun profile-1-fun (name)
 262   (cond ((fboundp name)
 263          (when (gethash name *profiled-fun-name->info*)
 264            (warn "~S is already profiled, so unprofiling it first." name)
 265            (unprofile-1-fun name))
 266          (profile-1-unprofiled-fun name))
 267         (t
 268          (warn "ignoring undefined function ~S" name)))
 269   (values))
 270
 271 ;;; Unprofile the named function, if it is profiled.
 272 (defun unprofile-1-fun (name)
 273   (let ((pinfo (gethash name *profiled-fun-name->info*)))
 274     (cond (pinfo
 275            (remhash name *profiled-fun-name->info*)
 276            (if (eq (fdefinition name) (profile-info-encapsulation-fun pinfo))
 277                (without-package-locks
 278                 (setf (fdefinition name) (profile-info-encapsulated-fun pinfo)))
 279                (warn "preserving current definition of redefined function ~S"
 280                      name)))
 281           (t
 282            (warn "~S is not a profiled function." name))))
 283   (values))
 284
 285 (defmacro profile (&rest names)
 286   #+sb-doc
 287   "PROFILE Name*
 288
 289    If no names are supplied, return the list of profiled functions.
 290
 291    If names are supplied, wrap profiling code around the named functions.
 292    As in TRACE, the names are not evaluated. A symbol names a function.
 293    A string names all the functions named by symbols in the named
 294    package. If a function is already profiled, then unprofile and
 295    reprofile (useful to notice function redefinition.)  If a name is
 296    undefined, then we give a warning and ignore it. See also
 297    UNPROFILE, REPORT and RESET."
 298   (if (null names)
 299       `(loop for k being each hash-key in *profiled-fun-name->info*
 300              collecting k)
 301       `(mapc-on-named-funs #'profile-1-fun ',names)))
 302
 303 (defmacro unprofile (&rest names)
 304   #+sb-doc
 305   "Unwrap any profiling code around the named functions, or if no names
 306   are given, unprofile all profiled functions. A symbol names
 307   a function. A string names all the functions named by symbols in the
 308   named package. NAMES defaults to the list of names of all currently
 309   profiled functions."
 310   (if names
 311       `(mapc-on-named-funs #'unprofile-1-fun ',names)
 312       `(unprofile-all)))
 313
 314 (defun unprofile-all ()
 315   (dohash ((name profile-info) *profiled-fun-name->info*
 316            :locked t)
 317     (declare (ignore profile-info))
 318     (unprofile-1-fun name)))
 319
 320 (defun reset ()
 321   "Reset the counters for all profiled functions."
 322   (dohash ((name profile-info) *profiled-fun-name->info* :locked t)
 323     (declare (ignore name))
 324     (funcall (profile-info-clear-stats-fun profile-info))))
 325 \f
 326 ;;;; reporting results
 327
 328 (defstruct (time-info (:copier nil))
 329   name
 330   calls
 331   seconds
 332   consing)
 333
 334 ;;; Return our best guess for the run time in a function, subtracting
 335 ;;; out factors for profiling overhead. We subtract out the internal
 336 ;;; overhead for each call to this function, since the internal
 337 ;;; overhead is the part of the profiling overhead for a function that
 338 ;;; is charged to that function.
 339 ;;;
 340 ;;; We also subtract out a factor for each call to a profiled function
 341 ;;; within this profiled function. This factor is the total profiling
 342 ;;; overhead *minus the internal overhead*. We don't subtract out the
 343 ;;; internal overhead, since it was already subtracted when the nested
 344 ;;; profiled functions subtracted their running time from the time for
 345 ;;; the enclosing function.
 346 (defun compensate-time (calls ticks profile)
 347   (let ((raw-compensated
 348          (- (/ (float ticks) (float +ticks-per-second+))
 349             (* (overhead-internal *overhead*) (float calls))
 350             (* (- (overhead-total *overhead*)
 351                   (overhead-internal *overhead*))
 352                (float profile)))))
 353     (max raw-compensated 0.0)))
 354
 355 (defun report ()
 356   "Report results from profiling. The results are approximately adjusted
 357 for profiling overhead. The compensation may be rather inaccurate when
 358 bignums are involved in runtime calculation, as in a very-long-running
 359 Lisp process."
 360   (unless (boundp '*overhead*)
 361     (setf *overhead*
 362           (compute-overhead)))
 363   (let ((time-info-list ())
 364         (no-call-name-list ()))
 365     (dohash ((name pinfo) *profiled-fun-name->info* :locked t)
 366       (unless (eq (fdefinition name)
 367                   (profile-info-encapsulation-fun pinfo))
 368         (warn "Function ~S has been redefined, so times may be inaccurate.~@
 369                PROFILE it again to record calls to the new definition."
 370               name))
 371       (multiple-value-bind (calls ticks consing profile)
 372           (funcall (profile-info-read-stats-fun pinfo))
 373         (if (zerop calls)
 374             (push name no-call-name-list)
 375             (push (make-time-info :name name
 376                                   :calls calls
 377                                   :seconds (compensate-time calls
 378                                                             ticks
 379                                                             profile)
 380                                   :consing consing)
 381                   time-info-list))))
 382
 383     (setf time-info-list
 384           (sort time-info-list
 385                 #'>=
 386                 :key #'time-info-seconds))
 387     (print-profile-table time-info-list)
 388
 389     (when no-call-name-list
 390       (format *trace-output*
 391               "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%"
 392               (sort no-call-name-list #'string<
 393                     :key (lambda (name)
 394                            (symbol-name (fun-name-block-name name))))))
 395
 396     (values)))
 397
 398
 399 (defun print-profile-table (time-info-list)
 400   (let ((total-seconds 0.0)
 401         (total-consed 0)
 402         (total-calls 0)
 403         (seconds-width (length "seconds"))
 404         (consed-width (length "consed"))
 405         (calls-width (length "calls"))
 406         (sec/call-width 10)
 407         (name-width 6))
 408     (dolist (time-info time-info-list)
 409       (incf total-seconds (time-info-seconds time-info))
 410       (incf total-consed (time-info-consing time-info))
 411       (incf total-calls (time-info-calls time-info)))
 412     (setf seconds-width (max (length (format nil "~10,3F" total-seconds))
 413                              seconds-width)
 414           calls-width (max (length (format nil "~:D" total-calls))
 415                            calls-width)
 416           consed-width (max (length (format nil "~:D" total-consed))
 417                             consed-width))
 418
 419     (flet ((dashes ()
 420              (dotimes (i (+ seconds-width consed-width calls-width
 421                             sec/call-width name-width
 422                             (* 5 3)))
 423                (write-char #\- *trace-output*))
 424              (terpri *trace-output*)))
 425       (format *trace-output* "~&~@{ ~v:@<~A~>~^|~}~%"
 426               seconds-width "seconds"
 427               (1+ consed-width) "consed"
 428               (1+ calls-width) "calls"
 429               (1+ sec/call-width) "sec/call"
 430               (1+ name-width) "name")
 431
 432       (dashes)
 433
 434       (dolist (time-info time-info-list)
 435         (format *trace-output* "~v,3F | ~v:D | ~v:D | ~10,6F | ~S~%"
 436                 seconds-width (time-info-seconds time-info)
 437                 consed-width (time-info-consing time-info)
 438                 calls-width (time-info-calls time-info)
 439                 (/ (time-info-seconds time-info)
 440                    (float (time-info-calls time-info)))
 441                 (time-info-name time-info)))
 442
 443       (dashes)
 444
 445       (format *trace-output* "~v,3F | ~v:D | ~v:D |            | Total~%"
 446                 seconds-width total-seconds
 447                 consed-width total-consed
 448                 calls-width total-calls)
 449
 450       (format *trace-output*
 451               "~%estimated total profiling overhead: ~4,2F seconds~%"
 452               (* (overhead-total *overhead*) (float total-calls)))
 453       (format *trace-output*
 454               "~&overhead estimation parameters:~%  ~Ss/call, ~Ss total profiling, ~Ss internal profiling~%"
 455               (overhead-call *overhead*)
 456               (overhead-total *overhead*)
 457               (overhead-internal *overhead*)))))
 458
 459 \f
 460 ;;;; overhead estimation
 461
 462 ;;; We average the timing overhead over this many iterations.
 463 ;;;
 464 ;;; (This is a variable, not a constant, so that it can be set in
 465 ;;; .sbclrc if desired. Right now, that's an unsupported extension
 466 ;;; that I (WHN) use for my own experimentation, but it might
 467 ;;; become supported someday. Comments?)
 468 (declaim (type unsigned-byte *timer-overhead-iterations*))
 469 (defparameter *timer-overhead-iterations*
 470   500000)
 471
 472 ;;; a dummy function that we profile to find profiling overhead
 473 (declaim (notinline compute-overhead-aux))
 474 (defun compute-overhead-aux (x)
 475   (declare (ignore x)))
 476
 477 ;;; Return a newly computed OVERHEAD object.
 478 (defun compute-overhead ()
 479   (format *debug-io* "~&measuring PROFILE overhead..")
 480   (flet ((frob ()
 481            (let ((start (get-internal-ticks))
 482                  (fun (symbol-function 'compute-overhead-aux)))
 483              (declare (type function fun))
 484              (dotimes (i *timer-overhead-iterations*)
 485                (funcall fun fun))
 486              (/ (float (- (get-internal-ticks) start))
 487                 (float +ticks-per-second+)
 488                 (float *timer-overhead-iterations*)))))
 489     (let (;; Measure unprofiled calls to estimate call overhead.
 490           (call-overhead (frob))
 491           total-overhead
 492           internal-overhead)
 493       ;; Measure profiled calls to estimate profiling overhead.
 494       (unwind-protect
 495           (progn
 496             (profile compute-overhead-aux)
 497             (setf total-overhead
 498                   (- (frob) call-overhead)))
 499         (let* ((pinfo (gethash 'compute-overhead-aux
 500                                *profiled-fun-name->info*))
 501                (read-stats-fun (profile-info-read-stats-fun pinfo))
 502                (time (nth-value 1 (funcall read-stats-fun))))
 503           (setf internal-overhead
 504                 (/ (float time)
 505                    (float +ticks-per-second+)
 506                    (float *timer-overhead-iterations*))))
 507         (unprofile compute-overhead-aux))
 508       (prog1
 509           (make-overhead :call call-overhead
 510                          :total total-overhead
 511                          :internal internal-overhead)
 512         (format *debug-io* "done~%")))))
 513
 514 ;;; It would be bad to compute *OVERHEAD*, save it into a .core file,
 515 ;;; then load the old *OVERHEAD* value from the .core file into a
 516 ;;; different machine running at a different speed. We avoid this by
 517 ;;; erasing *CALL-OVERHEAD* whenever we save a .core file.
 518 (defun profile-deinit ()
 519   (without-package-locks
 520     (makunbound '*overhead*)))