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 ;;; FIXME: It might make sense to replace this with something
  15 ;;; with finer resolution, e.g. milliseconds or microseconds.
  16 ;;; For that matter, maybe we should boost the internal clock
  17 ;;; up to something faster, like milliseconds.
  18
  19 (defconstant +ticks-per-second+ internal-time-units-per-second)
  20
  21 (declaim (inline get-internal-ticks))
  22 (defun get-internal-ticks () (get-internal-run-time))
  23 \f
  24 ;;;; implementation-dependent interfaces
  25
  26 #|
  27 ;;; To avoid unnecessary consing in the "encapsulation" code, we want
  28 ;;; find out the number of required arguments, and use &REST to
  29 ;;; capture only non-required arguments. This function returns (VALUES
  30 ;;; MIN-ARGS OPTIONALS-P), where MIN-ARGS is the number of required
  31 ;;; arguments and OPTIONALS-P is true iff there are any non-required
  32 ;;; arguments (such as &OPTIONAL, &REST, or &KEY).
  33 (declaim (ftype (function ((or symbol cons)) (values fixnum t)) fun-signature))
  34 (defun fun-signature (name)
  35   (let ((type (info :function :type name)))
  36     (cond ((not (function-type-p type))
  37            (values 0 t))
  38           (t
  39            (values (length (function-type-required type))
  40                    (or (function-type-optional type)
  41                        (function-type-keyp type)
  42                        (function-type-rest type)))))))
  43 |#
  44 \f
  45 ;;;; global data structures
  46
  47 ;;; We associate a PROFILE-INFO structure with each profiled function
  48 ;;; name. This holds the functions that we call to manipulate the
  49 ;;; closure which implements the encapsulation.
  50 (defvar *profiled-function-name->info* (make-hash-table))
  51 (defstruct (profile-info (:copier nil))
  52   (name              (required-argument) :read-only t)
  53   (encapsulated-fun  (required-argument) :type function :read-only t)
  54   (encapsulation-fun (required-argument) :type function :read-only t)
  55   (read-stats-fun    (required-argument) :type function :read-only t)
  56   (clear-stats-fun   (required-argument) :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 (required-argument) :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 (required-argument) :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 (required-argument) :type single-float :read-only t))
  95 (defvar *overhead*)
  96 (declaim (type overhead *overhead*))
  97 \f
  98 ;;;; profile encapsulations
  99
 100 ;;; Trade off space for time by handling the usual all-FIXNUM cases
 101 ;;; inline.
 102 (defmacro fastbig- (x y)
 103   (once-only ((x x) (y y))
 104     `(if (and (typep ,x 'fixnum)
 105               (typep ,y 'fixnum))
 106          (- ,x ,y)
 107          (- ,x ,y))))
 108 (defmacro fastbig-1+ (x)
 109   (once-only ((x x))
 110     `(if (typep ,x 'index)
 111          (1+ ,x)
 112          (1+ ,x))))
 113
 114 ;;; Return a collection of closures over the same lexical context,
 115 ;;;   (VALUES ENCAPSULATION-FUN READ-STATS-FUN CLEAR-STATS-FUN).
 116 ;;;
 117 ;;; ENCAPSULATION-FUN is a plug-in replacement for ENCAPSULATED-FUN,
 118 ;;; which updates statistics whenver it's called.
 119 ;;;
 120 ;;; READ-STATS-FUN returns the statistics:
 121 ;;;   (VALUES COUNT TIME CONSING PROFILE).
 122 ;;; COUNT is the count of calls to ENCAPSULATION-FUN. TICKS is
 123 ;;; the total number of ticks spent in ENCAPSULATED-FUN.
 124 ;;; CONSING is the total consing of ENCAPSULATION-FUN. PROFILE is the
 125 ;;; number of calls to the profiled function, stored for the purposes
 126 ;;; of trying to estimate that part of profiling overhead which occurs
 127 ;;; outside the interval between the profile wrapper function's timer
 128 ;;; calls.
 129 ;;;
 130 ;;; CLEAR-STATS-FUN clears the statistics.
 131 ;;;
 132 ;;; (The reason for implementing this as coupled closures, with the
 133 ;;; counts built into the lexical environment, is that we hope this
 134 ;;; will minimize profiling overhead.)
 135 (defun profile-encapsulation-lambdas (encapsulated-fun)
 136   (declare (type function encapsulated-fun))
 137   (let* ((count 0)
 138          (ticks 0)
 139          (consing 0)
 140          (profiles 0))
 141     (declare (type (or pcounter fixnum) count ticks consing profiles))
 142     (values
 143      ;; ENCAPSULATION-FUN
 144      (lambda (sb-c:&more arg-context arg-count)
 145        (declare (optimize speed safety))
 146        ;; Make sure that we're not recursing infinitely.
 147        (when (boundp '*computing-profiling-data-for*)
 148          (unprofile-all) ; to avoid further recursion
 149          (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.)~:@>"
 150                 *computing-profiling-data-for*
 151                 encapsulated-fun
 152                 encapsulated-fun))
 153        ;; FIXME: Probably when this is stable, we should optimize (SAFETY 0).
 154        (fastbig-incf-pcounter-or-fixnum count 1)
 155        (let ((dticks 0)
 156              (dconsing 0)
 157              (inner-enclosed-profiles 0))
 158          ;;(declare (type unsigned-byte dticks dconsing))
 159          ;;(declare (type unsigned-byte inner-enclosed-profiles))
 160          (aver (typep dticks 'unsigned-byte))
 161          (aver (typep dconsing 'unsigned-byte))
 162          (aver (typep inner-enclosed-profiles 'unsigned-byte))
 163          (multiple-value-prog1
 164              (let ((start-ticks (get-internal-ticks))
 165                    ;; KLUDGE: We add (THE UNSIGNED-BYTE ..) wrappers
 166                    ;; around GET-BYTES-CONSED because as of
 167                    ;; sbcl-0.6.4, at the time that the FTYPE of
 168                    ;; GET-BYTES-CONSED is DECLAIMed, the
 169                    ;; cross-compiler's type system isn't mature enough
 170                    ;; to do anything about it. -- WHN 20000503
 171                    (start-consing (the unsigned-byte (get-bytes-consed)))
 172                    (*enclosed-ticks* 0)
 173                    (*enclosed-consing* 0)
 174                    (*enclosed-profiles* 0))
 175                (declare (inline pcounter-or-fixnum->integer))
 176                (multiple-value-prog1
 177                    (multiple-value-call encapsulated-fun
 178                                         (sb-c:%more-arg-values arg-context
 179                                                                0
 180                                                                arg-count))
 181                  (let ((*computing-profiling-data-for* encapsulated-fun))
 182                    (setf dticks (fastbig- (get-internal-ticks) start-ticks)
 183                          dconsing (fastbig- (the unsigned-byte
 184                                               (get-bytes-consed))
 185                                             start-consing))
 186                    (setf inner-enclosed-profiles
 187                          (pcounter-or-fixnum->integer *enclosed-profiles*))
 188                    (when (minusp dticks) ; REMOVEME
 189                      (unprofile-all)
 190                      (error "huh? (GET-INTERNAL-TICKS)=~S START-TICKS=~S"
 191                             (get-internal-ticks) start-ticks))
 192                    (aver (not (minusp dconsing))) ; REMOVEME
 193                    (aver (not (minusp inner-enclosed-profiles))) ; REMOVEME
 194                    (let ((net-dticks (fastbig- dticks *enclosed-ticks*)))
 195                      (when (minusp net-dticks) ; REMOVEME
 196                        (unprofile-all)
 197                        (error "huh? DTICKS=~S, *ENCLOSED-TICKS*=~S"
 198                               dticks *enclosed-ticks*))
 199                      (fastbig-incf-pcounter-or-fixnum ticks net-dticks))
 200                    (let ((net-dconsing (fastbig- dconsing *enclosed-consing*)))
 201                      (when (minusp net-dconsing) ; REMOVEME
 202                        (unprofile-all)
 203                        (error "huh? DCONSING=~S, *ENCLOSED-CONSING*=~S"
 204                               dticks *enclosed-ticks*))
 205                      (fastbig-incf-pcounter-or-fixnum consing net-dconsing))
 206                    (fastbig-incf-pcounter-or-fixnum profiles
 207                                                     inner-enclosed-profiles))))
 208            (fastbig-incf-pcounter-or-fixnum *enclosed-ticks* dticks)
 209            (fastbig-incf-pcounter-or-fixnum *enclosed-consing* dconsing)
 210            (fastbig-incf-pcounter-or-fixnum *enclosed-profiles*
 211                                             (fastbig-1+
 212                                              inner-enclosed-profiles)))))
 213      ;; READ-STATS-FUN
 214      (lambda ()
 215        (values (pcounter-or-fixnum->integer count)
 216                (pcounter-or-fixnum->integer ticks)
 217                (pcounter-or-fixnum->integer consing)
 218                (pcounter-or-fixnum->integer profiles)))
 219      ;; CLEAR-STATS-FUN
 220      (lambda ()
 221        (setf count 0
 222              ticks 0
 223              consing 0
 224              profiles 0)))))
 225 \f
 226 ;;;; interfaces
 227
 228 ;;; A symbol or (SETF FOO) list names a function, a string names all
 229 ;;; the functions named by symbols in the named package.
 230 (defun mapc-on-named-functions (function names)
 231   (dolist (name names)
 232     (etypecase name
 233       (symbol (funcall function name))
 234       (list
 235        ;; We call this just for the side effect of checking that
 236        ;; NAME is a legal function name:
 237        (function-name-block-name name)
 238        ;; Then we map onto it.
 239        (funcall function name))
 240       (string (let ((package (find-undeleted-package-or-lose name)))
 241                 (do-symbols (symbol package)
 242                   (when (eq (symbol-package symbol) package)
 243                     (when (fboundp symbol)
 244                       (funcall function symbol))
 245                     (let ((setf-name `(setf ,symbol)))
 246                       (when (fboundp setf-name)
 247                         (funcall function setf-name)))))))))
 248   (values))
 249
 250 ;;; Profile the named function, which should exist and not be profiled
 251 ;;; already.
 252 (defun profile-1-unprofiled-function (name)
 253   (declare #.*optimize-byte-compilation*)
 254   (let ((encapsulated-fun (fdefinition name)))
 255     (multiple-value-bind (encapsulation-fun read-stats-fun clear-stats-fun)
 256         (profile-encapsulation-lambdas encapsulated-fun)
 257       (setf (fdefinition name)
 258             encapsulation-fun)
 259       (setf (gethash name *profiled-function-name->info*)
 260             (make-profile-info :name name
 261                                :encapsulated-fun encapsulated-fun
 262                                :encapsulation-fun encapsulation-fun
 263                                :read-stats-fun read-stats-fun
 264                                :clear-stats-fun clear-stats-fun))
 265       (values))))
 266
 267 ;;; Profile the named function. If already profiled, unprofile first.
 268 (defun profile-1-function (name)
 269   (declare #.*optimize-byte-compilation*)
 270   (cond ((fboundp name)
 271          (when (gethash name *profiled-function-name->info*)
 272            (warn "~S is already profiled, so unprofiling it first." name)
 273            (unprofile-1-function name))
 274          (profile-1-unprofiled-function name))
 275         (t
 276          (warn "ignoring undefined function ~S" name)))
 277   (values))
 278
 279 ;;; Unprofile the named function, if it is profiled.
 280 (defun unprofile-1-function (name)
 281   (declare #.*optimize-byte-compilation*)
 282   (let ((pinfo (gethash name *profiled-function-name->info*)))
 283     (cond (pinfo
 284            (remhash name *profiled-function-name->info*)
 285            (if (eq (fdefinition name) (profile-info-encapsulation-fun pinfo))
 286                (setf (fdefinition name) (profile-info-encapsulated-fun pinfo))
 287                (warn "preserving current definition of redefined function ~S"
 288                      name)))
 289           (t
 290            (warn "~S is not a profiled function." name))))
 291   (values))
 292
 293 (defmacro profile (&rest names)
 294   #+sb-doc
 295   "PROFILE Name*
 296
 297    If no names are supplied, return the list of profiled functions.
 298
 299    If names are supplied, wrap profiling code around the named functions.
 300    As in TRACE, the names are not evaluated. A symbol names a function.
 301    A string names all the functions named by symbols in the named
 302    package. If a function is already profiled, then unprofile and
 303    reprofile (useful to notice function redefinition.)  If a name is
 304    undefined, then we give a warning and ignore it. See also
 305    UNPROFILE, REPORT and RESET."
 306   (declare #.*optimize-byte-compilation*)
 307   (if (null names)
 308       `(loop for k being each hash-key in *profiled-function-name->info*
 309              collecting k)
 310       `(mapc-on-named-functions #'profile-1-function ',names)))
 311
 312 (defmacro unprofile (&rest names)
 313   #+sb-doc
 314   "Unwrap any profiling code around the named functions, or if no names
 315   are given, unprofile all profiled functions. A symbol names
 316   a function. A string names all the functions named by symbols in the
 317   named package. NAMES defaults to the list of names of all currently
 318   profiled functions."
 319   (declare #.*optimize-byte-compilation*)
 320   (if names
 321       `(mapc-on-named-functions #'unprofile-1-function ',names)
 322       `(unprofile-all)))
 323
 324 (defun unprofile-all ()
 325   (declare #.*optimize-byte-compilation*)
 326   (dohash (name profile-info *profiled-function-name->info*)
 327     (declare (ignore profile-info))
 328     (unprofile-1-function name)))
 329
 330 (defun reset ()
 331   "Reset the counters for all profiled functions."
 332   (dohash (name profile-info *profiled-function-name->info*)
 333     (declare (ignore name))
 334     (funcall (profile-info-clear-stats-fun profile-info))))
 335 \f
 336 ;;;; reporting results
 337
 338 (defstruct (time-info (:copier nil))
 339   name
 340   calls
 341   seconds
 342   consing)
 343
 344 ;;; Return our best guess for the run time in a function, subtracting
 345 ;;; out factors for profiling overhead. We subtract out the internal
 346 ;;; overhead for each call to this function, since the internal
 347 ;;; overhead is the part of the profiling overhead for a function that
 348 ;;; is charged to that function.
 349 ;;;
 350 ;;; We also subtract out a factor for each call to a profiled function
 351 ;;; within this profiled function. This factor is the total profiling
 352 ;;; overhead *minus the internal overhead*. We don't subtract out the
 353 ;;; internal overhead, since it was already subtracted when the nested
 354 ;;; profiled functions subtracted their running time from the time for
 355 ;;; the enclosing function.
 356 (defun compensate-time (calls ticks profile)
 357   (let ((raw-compensated
 358          (- (/ (float ticks) (float +ticks-per-second+))
 359             (* (overhead-internal *overhead*) (float calls))
 360             (* (- (overhead-total *overhead*)
 361                   (overhead-internal *overhead*))
 362                (float profile)))))
 363     (max raw-compensated 0.0)))
 364
 365 (defun report ()
 366   "Report results from profiling. The results are
 367 approximately adjusted for profiling overhead, but when RAW is true
 368 the unadjusted results are reported. The compensation may be somewhat
 369 inaccurate when bignums are involved in runtime calculation, as in
 370 a very-long-running Lisp process."
 371   (declare #.*optimize-external-despite-byte-compilation*)
 372   (unless (boundp '*overhead*)
 373     (setf *overhead*
 374           (compute-overhead)))
 375   (let ((time-info-list ())
 376         (no-call-name-list ()))
 377     (dohash (name pinfo *profiled-function-name->info*)
 378       (unless (eq (fdefinition name)
 379                   (profile-info-encapsulation-fun pinfo))
 380         (warn "Function ~S has been redefined, so times may be inaccurate.~@
 381                PROFILE it again to record calls to the new definition."
 382               name))
 383       (multiple-value-bind (calls ticks consing profile)
 384           (funcall (profile-info-read-stats-fun pinfo))
 385         (if (zerop calls)
 386             (push name no-call-name-list)
 387             (push (make-time-info :name name
 388                                   :calls calls
 389                                   :seconds (compensate-time calls
 390                                                             ticks
 391                                                             profile)
 392                                   :consing consing)
 393                   time-info-list))))
 394
 395     (setf time-info-list
 396           (sort time-info-list
 397                 #'>=
 398                 :key #'time-info-seconds))
 399
 400     (format *trace-output*
 401             "~&  seconds  |  consed   |  calls  |  sec/call  |  name~@
 402                ------------------------------------------------------~%")
 403
 404     (let ((total-time 0.0)
 405           (total-consed 0)
 406           (total-calls 0))
 407       (dolist (time-info time-info-list)
 408         (incf total-time (time-info-seconds time-info))
 409         (incf total-calls (time-info-calls time-info))
 410         (incf total-consed (time-info-consing time-info))
 411         (format *trace-output*
 412                 "~10,3F | ~9:D | ~7:D | ~10,6F | ~S~%"
 413                 (time-info-seconds time-info)
 414                 (time-info-consing time-info)
 415                 (time-info-calls time-info)
 416                 (/ (time-info-seconds time-info)
 417                    (float (time-info-calls time-info)))
 418                 (time-info-name time-info)))
 419       (format *trace-output*
 420               "------------------------------------------------------~@
 421               ~10,3F | ~9:D | ~7:D |        | Total~%"
 422               total-time total-consed total-calls)
 423       (format *trace-output*
 424               "~%estimated total profiling overhead: ~4,2F seconds~%"
 425               (* (overhead-total *overhead*) (float total-calls)))
 426       (format *trace-output*
 427               "~&overhead estimation parameters:~%  ~Ss/call, ~Ss total profiling, ~Ss internal profiling~%"
 428               (overhead-call *overhead*)
 429               (overhead-total *overhead*)
 430               (overhead-internal *overhead*)))
 431
 432     (when no-call-name-list
 433       (format *trace-output*
 434               "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%"
 435               (sort no-call-name-list #'string<
 436                     :key (lambda (name)
 437                            (symbol-name (function-name-block-name name))))))
 438
 439     (values)))
 440 \f
 441 ;;;; overhead estimation
 442
 443 ;;; We average the timing overhead over this many iterations.
 444 (defconstant +timer-overhead-iterations+
 445   50 ; REMOVEME
 446   ;;50000
 447   )
 448
 449 ;;; a dummy function that we profile to find profiling overhead
 450 (declaim (notinline compute-overhead-aux))
 451 (defun compute-overhead-aux (x)
 452   (declare (ignore x)))
 453
 454 ;;; Return a newly computed OVERHEAD object.
 455 (defun compute-overhead ()
 456   (flet ((frob ()
 457            (let ((start (get-internal-ticks))
 458                  (fun (symbol-function 'compute-overhead-aux)))
 459              (dotimes (i +timer-overhead-iterations+)
 460                (funcall fun fun))
 461              (/ (float (- (get-internal-ticks) start))
 462                 (float +ticks-per-second+)
 463                 (float +timer-overhead-iterations+)))))
 464     (let (;; Measure unprofiled calls to estimate call overhead.
 465           (call-overhead (frob))
 466           total-overhead
 467           internal-overhead)
 468       ;; Measure profiled calls to estimate profiling overhead.
 469       (unwind-protect
 470           (progn
 471             (profile compute-overhead-aux)
 472             (setf total-overhead
 473                   (- (frob) call-overhead)))
 474         (let* ((pinfo (gethash 'compute-overhead-aux
 475                                *profiled-function-name->info*))
 476                (read-stats-fun (profile-info-read-stats-fun pinfo))
 477                (time (nth-value 1 (funcall read-stats-fun))))
 478           (setf internal-overhead
 479                 (/ (float time)
 480                    (float +ticks-per-second+)
 481                    (float +timer-overhead-iterations+))))
 482         (unprofile compute-overhead-aux))
 483       (make-overhead :call call-overhead
 484                      :total total-overhead
 485                      :internal internal-overhead))))
 486
 487 ;;; It would be bad to compute *OVERHEAD*, save it into a .core file,
 488 ;;; then load old *OVERHEAD* value from the .core file into a
 489 ;;; different machine running at a different speed. We avoid this by
 490 ;;; erasing *CALL-OVERHEAD* whenever we save a .core file.
 491 (pushnew (lambda ()
 492            (makunbound '*overhead*))
 493          *before-save-initializations*)