;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
-(in-package "SB-PROFILE")
+(in-package "SB-PROFILE") ; (SB-, not SB!, since we're built in warm load.)
\f
;;;; reading internal run time with high resolution and low overhead
;;; FIXME: It might make sense to replace this with something
;;; with finer resolution, e.g. milliseconds or microseconds.
+;;; For that matter, maybe we should boost the internal clock
+;;; up to something faster, like milliseconds.
(defconstant +ticks-per-second+ internal-time-units-per-second)
(declaim (inline get-internal-ticks))
(defun get-internal-ticks () (get-internal-run-time))
\f
-;;;; PCOUNTER
-
-;;; a PCOUNTER is used to represent an integer quantity which can grow
-;;; bigger than a fixnum, but typically does so, if at all, in many
-;;; small steps, where we don't want to cons on every step. (Total
-;;; system consing, time spent in a profiled function, and bytes
-;;; consed in a profiled function are all examples of such
-;;; quantities.)
-(defstruct (pcounter (:copier nil))
- (integer 0 :type integer)
- (fixnum 0 :type fixnum))
-
-(declaim (ftype (function (pcounter integer) pcounter) incf-pcounter))
-(declaim (inline incf-pcounter))
-(defun incf-pcounter (pcounter delta)
- (let ((sum (+ (pcounter-fixnum pcounter) delta)))
- (cond ((typep sum 'fixnum)
- (setf (pcounter-fixnum pcounter) sum))
- (t
- (incf (pcounter-integer pcounter) sum)
- (setf (pcounter-fixnum pcounter) 0))))
- pcounter)
-
-(declaim (ftype (function (pcounter) integer) pcounter->integer))
-(declaim (inline pcounter->integer))
-(defun pcounter->integer (pcounter)
- (+ (pcounter-integer pcounter)
- (pcounter-fixnum pcounter)))
-\f
-;;;; operations on (OR PCOUNTER FIXNUM)
-;;;;
-;;;; When we don't want to cons a PCOUNTER unless we're forced to, we
-;;;; start with a FIXNUM counter and only create a PCOUNTER if the
-;;;; FIXNUM overflows.
-
-(declaim (ftype (function ((or pcounter fixnum) integer) (or pcounter fixnum)) %incf-pcounter-or-fixnum))
-(declaim (inline %incf-pcounter-or-fixnum))
-(defun %incf-pcounter-or-fixnum (x delta)
- (etypecase x
- (fixnum
- (let ((sum (+ x delta)))
- (if (typep sum 'fixnum)
- sum
- (make-pcounter :integer sum))))
- (pcounter
- (incf-pcounter x delta))))
-
-(define-modify-macro incf-pcounter-or-fixnum (delta) %incf-pcounter-or-fixnum)
-
-;;; Trade off space for execution time by handling the common fast
-;;; (TYPEP DELTA 'FIXNUM) case inline and only calling generic
-;;; arithmetic as a last resort.
-(defmacro fastbig-incf-pcounter-or-fixnum (x delta)
- (once-only ((delta delta))
- `(etypecase ,delta
- (fixnum (incf-pcounter-or-fixnum ,x ,delta))
- (integer (incf-pcounter-or-fixnum ,x ,delta)))))
-
-(declaim (ftype (function ((or pcounter fixnum)) integer) pcounter-or-fixnum->integer))
-(declaim (maybe-inline pcounter-or-fixnum->integer))
-(defun pcounter-or-fixnum->integer (x)
- (etypecase x
- (fixnum x)
- (pcounter (pcounter->integer x))))
-\f
;;;; implementation-dependent interfaces
#|
;;; name. This holds the functions that we call to manipulate the
;;; closure which implements the encapsulation.
(defvar *profiled-function-name->info* (make-hash-table))
-(defstruct profile-info
+(defstruct (profile-info (:copier nil))
(name (required-argument) :read-only t)
(encapsulated-fun (required-argument) :type function :read-only t)
(encapsulation-fun (required-argument) :type function :read-only t)
(defvar *enclosed-profiles* 0)
(declaim (type (or pcounter fixnum) *enclosed-profiles*))
+;;; the encapsulated function we're currently computing profiling data
+;;; for, recorded so that we can detect the problem of
+;;; PROFILE-computing machinery calling a function which has itself
+;;; been PROFILEd
+(defvar *computing-profiling-data-for*)
+
;;; the components of profiling overhead
-(defstruct overhead
+(defstruct (overhead (:copier nil))
;; the number of ticks a bare function call takes. This is
;; factored into the other overheads, but not used for itself.
(call (required-argument) :type single-float :read-only t)
;;; inline.
(defmacro fastbig- (x y)
(once-only ((x x) (y y))
- `(if (and (typep ,x 'fixnum)
- (typep ,y 'fixnum))
+ `(if (and (typep ,x '(and fixnum unsigned-byte))
+ (typep ,y '(and fixnum unsigned-byte)))
+ ;; special case: can use fixnum arithmetic and be guaranteed
+ ;; the result is also a fixnum
(- ,x ,y)
+ ;; general case
(- ,x ,y))))
(defmacro fastbig-1+ (x)
(once-only ((x x))
;;; will minimize profiling overhead.)
(defun profile-encapsulation-lambdas (encapsulated-fun)
(declare (type function encapsulated-fun))
- (declare (optimize speed safety))
(let* ((count 0)
(ticks 0)
(consing 0)
(values
;; ENCAPSULATION-FUN
(lambda (sb-c:&more arg-context arg-count)
- #+nil (declare (optimize (speed 3) (safety 0))) ; FIXME: remove #+NIL?
+ (declare (optimize speed safety))
+ ;; Make sure that we're not recursing infinitely.
+ (when (boundp '*computing-profiling-data-for*)
+ (unprofile-all) ; to avoid further recursion
+ (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.)~:@>"
+ *computing-profiling-data-for*
+ encapsulated-fun
+ encapsulated-fun))
+ ;; FIXME: Probably when this is stable, we should optimize (SAFETY 0).
(fastbig-incf-pcounter-or-fixnum count 1)
(let ((dticks 0)
(dconsing 0)
(inner-enclosed-profiles 0))
(declare (type unsigned-byte dticks dconsing))
(declare (type unsigned-byte inner-enclosed-profiles))
+ (aver (typep dticks 'unsigned-byte))
+ (aver (typep dconsing 'unsigned-byte))
+ (aver (typep inner-enclosed-profiles 'unsigned-byte))
(multiple-value-prog1
- (let ((start-ticks (get-internal-ticks))
- ;; KLUDGE: We add (THE UNSIGNED-BYTE ..) wrappers
- ;; around GET-BYTES-CONSED because as of
- ;; sbcl-0.6.4, at the time that the FTYPE of
- ;; GET-BYTES-CONSED is DECLAIMed, the
- ;; cross-compiler's type system isn't mature enough
- ;; to do anything about it. -- WHN 20000503
- (start-consing (the unsigned-byte (get-bytes-consed)))
- (*enclosed-ticks* 0)
- (*enclosed-consing* 0)
- (*enclosed-profiles* 0))
+ (let* ((start-ticks (get-internal-ticks))
+ (*enclosed-ticks* 0)
+ (*enclosed-consing* 0)
+ (*enclosed-profiles* 0)
+ (nbf-pcounter *n-bytes-freed-or-purified-pcounter*)
+ ;; Typically NBF-PCOUNTER will represent a bignum.
+ ;; In general we don't want to cons up a new
+ ;; bignum for every encapsulated call, so instead
+ ;; we keep track of the PCOUNTER internals, so
+ ;; that as long as we only cons small amounts,
+ ;; we'll almost always just do fixnum arithmetic.
+ ;; (And for encapsulated functions which cons
+ ;; large amounts, then we don't much care about a
+ ;; single extra consed bignum.)
+ (start-consing-integer (pcounter-integer nbf-pcounter))
+ (start-consing-fixnum (pcounter-fixnum nbf-pcounter)))
(declare (inline pcounter-or-fixnum->integer))
(multiple-value-prog1
(multiple-value-call encapsulated-fun
(sb-c:%more-arg-values arg-context
0
arg-count))
- (setf dticks (fastbig- (get-internal-ticks) start-ticks)
- dconsing (fastbig- (the unsigned-byte
- (get-bytes-consed))
- start-consing))
- (setf inner-enclosed-profiles
- (pcounter-or-fixnum->integer *enclosed-profiles*))
- (fastbig-incf-pcounter-or-fixnum ticks (fastbig-
- dticks
- *enclosed-ticks*))
- (fastbig-incf-pcounter-or-fixnum consing
- (fastbig-
- dconsing
- *enclosed-consing*))
- (fastbig-incf-pcounter-or-fixnum profiles
- inner-enclosed-profiles)))
+ (let ((*computing-profiling-data-for* encapsulated-fun))
+ (setf dticks (fastbig- (get-internal-ticks) start-ticks))
+ (setf dconsing
+ (if (eq (pcounter-integer nbf-pcounter)
+ start-consing-integer)
+ (- (pcounter-fixnum nbf-pcounter)
+ start-consing-fixnum)
+ (- (get-bytes-consed)
+ (+ (pcounter-integer nbf-pcounter)
+ (pcounter-fixnum nbf-pcounter)))))
+ (setf inner-enclosed-profiles
+ (pcounter-or-fixnum->integer *enclosed-profiles*))
+ (let ((net-dticks (fastbig- dticks *enclosed-ticks*)))
+ (fastbig-incf-pcounter-or-fixnum ticks net-dticks))
+ (let ((net-dconsing (fastbig- dconsing *enclosed-consing*)))
+ (fastbig-incf-pcounter-or-fixnum consing net-dconsing))
+ (fastbig-incf-pcounter-or-fixnum profiles
+ inner-enclosed-profiles))))
(fastbig-incf-pcounter-or-fixnum *enclosed-ticks* dticks)
(fastbig-incf-pcounter-or-fixnum *enclosed-consing* dconsing)
(fastbig-incf-pcounter-or-fixnum *enclosed-profiles*
consing 0
profiles 0)))))
\f
-;;; interfaces
+;;;; interfaces
;;; A symbol or (SETF FOO) list names a function, a string names all
;;; the functions named by symbols in the named package.
;;; Profile the named function, which should exist and not be profiled
;;; already.
(defun profile-1-unprofiled-function (name)
+ (declare #.*optimize-byte-compilation*)
(let ((encapsulated-fun (fdefinition name)))
(multiple-value-bind (encapsulation-fun read-stats-fun clear-stats-fun)
(profile-encapsulation-lambdas encapsulated-fun)
;;; Profile the named function. If already profiled, unprofile first.
(defun profile-1-function (name)
+ (declare #.*optimize-byte-compilation*)
(cond ((fboundp name)
(when (gethash name *profiled-function-name->info*)
(warn "~S is already profiled, so unprofiling it first." name)
;;; Unprofile the named function, if it is profiled.
(defun unprofile-1-function (name)
+ (declare #.*optimize-byte-compilation*)
(let ((pinfo (gethash name *profiled-function-name->info*)))
(cond (pinfo
(remhash name *profiled-function-name->info*)
reprofile (useful to notice function redefinition.) If a name is
undefined, then we give a warning and ignore it. See also
UNPROFILE, REPORT and RESET."
+ (declare #.*optimize-byte-compilation*)
(if (null names)
`(loop for k being each hash-key in *profiled-function-name->info*
collecting k)
a function. A string names all the functions named by symbols in the
named package. NAMES defaults to the list of names of all currently
profiled functions."
+ (declare #.*optimize-byte-compilation*)
(if names
`(mapc-on-named-functions #'unprofile-1-function ',names)
`(unprofile-all)))
(defun unprofile-all ()
+ (declare #.*optimize-byte-compilation*)
(dohash (name profile-info *profiled-function-name->info*)
(declare (ignore profile-info))
(unprofile-1-function name)))
\f
;;;; reporting results
-(defstruct time-info
+(defstruct (time-info (:copier nil))
name
calls
seconds
(max raw-compensated 0.0)))
(defun report ()
- "Report results from profiling. The results are
-approximately adjusted for profiling overhead, but when RAW is true
-the unadjusted results are reported. The compensation may be somewhat
-inaccurate when bignums are involved in runtime calculation, as in
-a very-long-running Lisp process."
- (declare (optimize (speed 0)))
+ "Report results from profiling. The results are approximately adjusted
+for profiling overhead. The compensation may be rather inaccurate when
+bignums are involved in runtime calculation, as in a very-long-running
+Lisp process."
+ (declare #.*optimize-external-despite-byte-compilation*)
(unless (boundp '*overhead*)
(setf *overhead*
(compute-overhead)))
;;;; overhead estimation
;;; We average the timing overhead over this many iterations.
-(defconstant +timer-overhead-iterations+ 50000)
+;;;
+;;; (This is a variable, not a constant, so that it can be set in
+;;; .sbclrc if desired. Right now, that's an unsupported extension
+;;; that I (WHN) use for my own experimentation, but it might
+;;; become supported someday. Comments?)
+(declaim (type unsigned-byte *timer-overhead-iterations*))
+(defvar *timer-overhead-iterations*
+ 500000)
;;; a dummy function that we profile to find profiling overhead
(declaim (notinline compute-overhead-aux))
;;; Return a newly computed OVERHEAD object.
(defun compute-overhead ()
+ (format *debug-io* "~&measuring PROFILE overhead..")
(flet ((frob ()
(let ((start (get-internal-ticks))
(fun (symbol-function 'compute-overhead-aux)))
- (dotimes (i +timer-overhead-iterations+)
+ (dotimes (i *timer-overhead-iterations*)
(funcall fun fun))
(/ (float (- (get-internal-ticks) start))
(float +ticks-per-second+)
- (float +timer-overhead-iterations+)))))
+ (float *timer-overhead-iterations*)))))
(let (;; Measure unprofiled calls to estimate call overhead.
(call-overhead (frob))
total-overhead
(setf internal-overhead
(/ (float time)
(float +ticks-per-second+)
- (float +timer-overhead-iterations+))))
+ (float *timer-overhead-iterations*))))
(unprofile compute-overhead-aux))
- (make-overhead :call call-overhead
- :total total-overhead
- :internal internal-overhead))))
+ (prog1
+ (make-overhead :call call-overhead
+ :total total-overhead
+ :internal internal-overhead)
+ (format *debug-io* "done~%")))))
;;; It would be bad to compute *OVERHEAD*, save it into a .core file,
-;;; then load old *OVERHEAD* value from the .core file into a
+;;; then load the old *OVERHEAD* value from the .core file into a
;;; different machine running at a different speed. We avoid this by
;;; erasing *CALL-OVERHEAD* whenever we save a .core file.
(pushnew (lambda ()