X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprofile.lisp;h=a381821f1fd398826d7cb8f3aa6431aaa24124d2;hb=a1a2c079c7654defb618baad0dddcf0eaf2ce64f;hp=def790885cb4597bd373cdaf5f21f8cdd6424349;hpb=f3af39f1a29391c2cc9f3308bc0a9ea6d39fb8eb;p=sbcl.git diff --git a/src/code/profile.lisp b/src/code/profile.lisp index def7908..a381821 100644 --- a/src/code/profile.lisp +++ b/src/code/profile.lisp @@ -101,9 +101,12 @@ ;;; 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)) @@ -155,23 +158,28 @@ (let ((dticks 0) (dconsing 0) (inner-enclosed-profiles 0)) - ;;(declare (type unsigned-byte dticks dconsing)) - ;;(declare (type unsigned-byte inner-enclosed-profiles)) + (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 @@ -179,29 +187,20 @@ 0 arg-count)) (let ((*computing-profiling-data-for* encapsulated-fun)) - (setf dticks (fastbig- (get-internal-ticks) start-ticks) - dconsing (fastbig- (the unsigned-byte - (get-bytes-consed)) - start-consing)) + (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*)) - (when (minusp dticks) ; REMOVEME - (unprofile-all) - (error "huh? (GET-INTERNAL-TICKS)=~S START-TICKS=~S" - (get-internal-ticks) start-ticks)) - (aver (not (minusp dconsing))) ; REMOVEME - (aver (not (minusp inner-enclosed-profiles))) ; REMOVEME (let ((net-dticks (fastbig- dticks *enclosed-ticks*))) - (when (minusp net-dticks) ; REMOVEME - (unprofile-all) - (error "huh? DTICKS=~S, *ENCLOSED-TICKS*=~S" - dticks *enclosed-ticks*)) (fastbig-incf-pcounter-or-fixnum ticks net-dticks)) (let ((net-dconsing (fastbig- dconsing *enclosed-consing*))) - (when (minusp net-dconsing) ; REMOVEME - (unprofile-all) - (error "huh? DCONSING=~S, *ENCLOSED-CONSING*=~S" - dticks *enclosed-ticks*)) (fastbig-incf-pcounter-or-fixnum consing net-dconsing)) (fastbig-incf-pcounter-or-fixnum profiles inner-enclosed-profiles)))) @@ -363,11 +362,10 @@ (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." + "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* @@ -441,10 +439,14 @@ a very-long-running Lisp process." ;;;; overhead estimation ;;; We average the timing overhead over this many iterations. -(defconstant +timer-overhead-iterations+ - 50 ; REMOVEME - ;;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)) @@ -453,14 +455,15 @@ 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+) + (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 @@ -478,14 +481,16 @@ a very-long-running Lisp process." (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 ()