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