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