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