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