X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprofile.lisp;h=0a257b35aa656dd51c0932cdb7abd674d6fc3cda;hb=860543cc7ba0266e41e1d41ac9b6a208f3795f1a;hp=ecaaa1a85b64bc2ca10896d790d06f54be1b728b;hpb=cfb9e3640e34706acdfccd26236024de259f3b4f;p=sbcl.git diff --git a/src/code/profile.lisp b/src/code/profile.lisp index ecaaa1a..0a257b3 100644 --- a/src/code/profile.lisp +++ b/src/code/profile.lisp @@ -7,83 +7,20 @@ ;;;; 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.) ;;;; 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)) -;;;; 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))) - -;;;; 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)))) - ;;;; implementation-dependent interfaces #| @@ -96,13 +33,13 @@ (declaim (ftype (function ((or symbol cons)) (values fixnum t)) fun-signature)) (defun fun-signature (name) (let ((type (info :function :type name))) - (cond ((not (function-type-p type)) + (cond ((not (fun-type-p type)) (values 0 t)) (t - (values (length (function-type-required type)) - (or (function-type-optional type) - (function-type-keyp type) - (function-type-rest type))))))) + (values (length (fun-type-required type)) + (or (fun-type-optional type) + (fun-type-keyp type) + (fun-type-rest type))))))) |# ;;;; global data structures @@ -110,13 +47,17 @@ ;;; We associate a PROFILE-INFO structure with each profiled function ;;; 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 - (name (required-argument) :read-only t) - (encapsulated-fun (required-argument) :type function :read-only t) - (encapsulation-fun (required-argument) :type function :read-only t) - (read-stats-fun (required-argument) :type function :read-only t) - (clear-stats-fun (required-argument) :type function :read-only t)) +(defvar *profiled-fun-name->info* + (make-hash-table + ;; EQL testing isn't good enough for generalized function names + ;; like (SETF FOO). + :test 'equal)) +(defstruct (profile-info (:copier nil)) + (name (missing-arg) :read-only t) + (encapsulated-fun (missing-arg) :type function :read-only t) + (encapsulation-fun (missing-arg) :type function :read-only t) + (read-stats-fun (missing-arg) :type function :read-only t) + (clear-stats-fun (missing-arg) :type function :read-only t)) ;;; These variables are used to subtract out the time and consing for ;;; recursive and other dynamically nested profiled calls. The total @@ -138,29 +79,38 @@ (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) + (call (missing-arg) :type single-float :read-only t) ;; the number of ticks that will be charged to a profiled ;; function due to the profiling code - (internal (required-argument) :type single-float :read-only t) + (internal (missing-arg) :type single-float :read-only t) ;; the number of ticks of overhead for profiling that a single ;; profiled call adds to the total runtime for the program - (total (required-argument) :type single-float :read-only t)) + (total (missing-arg) :type single-float :read-only t)) (defvar *overhead*) (declaim (type overhead *overhead*)) +(makunbound '*overhead*) ; in case we reload this file when tweaking ;;;; profile encapsulations -;;; Trade off space for time by handling the usual all-FIXNUM cases -;;; inline. +;;; Trade off space for time by handling the usual all-FIXNUM cases 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)) @@ -191,7 +141,6 @@ ;;; 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) @@ -199,47 +148,58 @@ (declare (type (or pcounter fixnum) count ticks consing profiles)) (values ;; ENCAPSULATION-FUN - (lambda (sb-c:&more arg-context arg-count) - #+nil (declare (optimize (speed 3) (safety 0))) ; FIXME: remove #+NIL? + (lambda (&more arg-context arg-count) + (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 "~@" + *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)) - (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)) + (aver (typep dticks 'unsigned-byte)) + (aver (typep dconsing 'unsigned-byte)) + (aver (typep inner-enclosed-profiles 'unsigned-byte)) + (unwind-protect + (let* ((start-ticks (get-internal-ticks)) + (*enclosed-ticks* 0) + (*enclosed-consing* 0) + (*enclosed-profiles* 0) + (nbf0 *n-bytes-freed-or-purified*) + (dynamic-usage-0 (sb-kernel:dynamic-usage))) (declare (inline pcounter-or-fixnum->integer)) - (multiple-value-prog1 + (unwind-protect (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) + (dynamic-usage-1 (sb-kernel:dynamic-usage))) + (setf dticks (fastbig- (get-internal-ticks) start-ticks)) + (setf dconsing + (if (eql *n-bytes-freed-or-purified* nbf0) + ;; common special case where we can avoid + ;; bignum arithmetic + (- dynamic-usage-1 dynamic-usage-0) + ;; general case + (- (get-bytes-consed) nbf0 dynamic-usage-0))) + (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 + (pcounter-or-fixnum->integer + *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* @@ -258,18 +218,16 @@ consing 0 profiles 0))))) -;;; interfaces +;;;; interfaces ;;; A symbol or (SETF FOO) list names a function, a string names all ;;; the functions named by symbols in the named package. -(defun mapc-on-named-functions (function names) +(defun mapc-on-named-funs (function names) (dolist (name names) (etypecase name (symbol (funcall function name)) (list - ;; We call this just for the side effect of checking that - ;; NAME is a legal function name: - (function-name-block-name name) + (legal-fun-name-or-type-error name) ;; Then we map onto it. (funcall function name)) (string (let ((package (find-undeleted-package-or-lose name))) @@ -284,13 +242,13 @@ ;;; Profile the named function, which should exist and not be profiled ;;; already. -(defun profile-1-unprofiled-function (name) +(defun profile-1-unprofiled-fun (name) (let ((encapsulated-fun (fdefinition name))) (multiple-value-bind (encapsulation-fun read-stats-fun clear-stats-fun) (profile-encapsulation-lambdas encapsulated-fun) (setf (fdefinition name) encapsulation-fun) - (setf (gethash name *profiled-function-name->info*) + (setf (gethash name *profiled-fun-name->info*) (make-profile-info :name name :encapsulated-fun encapsulated-fun :encapsulation-fun encapsulation-fun @@ -299,27 +257,27 @@ (values)))) ;;; Profile the named function. If already profiled, unprofile first. -(defun profile-1-function (name) +(defun profile-1-fun (name) (cond ((fboundp name) - (when (gethash name *profiled-function-name->info*) + (when (gethash name *profiled-fun-name->info*) (warn "~S is already profiled, so unprofiling it first." name) - (unprofile-1-function name)) - (profile-1-unprofiled-function name)) + (unprofile-1-fun name)) + (profile-1-unprofiled-fun name)) (t (warn "ignoring undefined function ~S" name))) (values)) ;;; Unprofile the named function, if it is profiled. -(defun unprofile-1-function (name) - (let ((pinfo (gethash name *profiled-function-name->info*))) +(defun unprofile-1-fun (name) + (let ((pinfo (gethash name *profiled-fun-name->info*))) (cond (pinfo - (remhash name *profiled-function-name->info*) + (remhash name *profiled-fun-name->info*) (if (eq (fdefinition name) (profile-info-encapsulation-fun pinfo)) (setf (fdefinition name) (profile-info-encapsulated-fun pinfo)) (warn "preserving current definition of redefined function ~S" name))) (t - (warn "~S is not a profiled function.")))) + (warn "~S is not a profiled function." name)))) (values)) (defmacro profile (&rest names) @@ -336,9 +294,9 @@ undefined, then we give a warning and ignore it. See also UNPROFILE, REPORT and RESET." (if (null names) - `(loop for k being each hash-key in *profiled-function-name->info* + `(loop for k being each hash-key in *profiled-fun-name->info* collecting k) - `(mapc-on-named-functions #'profile-1-function ',names))) + `(mapc-on-named-funs #'profile-1-fun ',names))) (defmacro unprofile (&rest names) #+sb-doc @@ -348,23 +306,23 @@ named package. NAMES defaults to the list of names of all currently profiled functions." (if names - `(mapc-on-named-functions #'unprofile-1-function ',names) + `(mapc-on-named-funs #'unprofile-1-fun ',names) `(unprofile-all))) (defun unprofile-all () - (dohash (name profile-info *profiled-function-name->info*) + (dohash (name profile-info *profiled-fun-name->info*) (declare (ignore profile-info)) - (unprofile-1-function name))) + (unprofile-1-fun name))) (defun reset () "Reset the counters for all profiled functions." - (dohash (name profile-info *profiled-function-name->info*) + (dohash (name profile-info *profiled-fun-name->info*) (declare (ignore name)) (funcall (profile-info-clear-stats-fun profile-info)))) ;;;; reporting results -(defstruct time-info +(defstruct (time-info (:copier nil)) name calls seconds @@ -392,18 +350,16 @@ (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." (unless (boundp '*overhead*) (setf *overhead* (compute-overhead))) (let ((time-info-list ()) (no-call-name-list ())) - (dohash (name pinfo *profiled-function-name->info*) + (dohash (name pinfo *profiled-fun-name->info*) (unless (eq (fdefinition name) (profile-info-encapsulation-fun pinfo)) (warn "Function ~S has been redefined, so times may be inaccurate.~@ @@ -463,14 +419,21 @@ a very-long-running Lisp process." "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%" (sort no-call-name-list #'string< :key (lambda (name) - (symbol-name (function-name-block-name name)))))) + (symbol-name (fun-name-block-name name)))))) (values))) ;;;; 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*)) +(defparameter *timer-overhead-iterations* + 500000) ;;; a dummy function that we profile to find profiling overhead (declaim (notinline compute-overhead-aux)) @@ -479,14 +442,16 @@ a very-long-running Lisp process." ;;; 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+) + (declare (type function fun)) + (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 @@ -498,20 +463,22 @@ a very-long-running Lisp process." (setf total-overhead (- (frob) call-overhead))) (let* ((pinfo (gethash 'compute-overhead-aux - *profiled-function-name->info*)) + *profiled-fun-name->info*)) (read-stats-fun (profile-info-read-stats-fun pinfo)) (time (nth-value 1 (funcall read-stats-fun)))) (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 ()