X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprofile.lisp;h=30bd69d9c55bcd5c9e40dd88ff0d7a83f6e132a2;hb=ff92598854bf7cae8d57fe49cef4d9a98e1ab345;hp=500ac97b59c46574e7ac0eee48124b0e099bb19d;hpb=f4f18b9dcdaf1948947b1747f5bfa766a1a0ee4c;p=sbcl.git diff --git a/src/code/profile.lisp b/src/code/profile.lisp index 500ac97..30bd69d 100644 --- a/src/code/profile.lisp +++ b/src/code/profile.lisp @@ -33,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 @@ -47,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)) +(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 (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)) + (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 @@ -85,21 +89,20 @@ (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 '(and fixnum unsigned-byte)) @@ -164,7 +167,7 @@ (aver (typep dticks 'unsigned-byte)) (aver (typep dconsing 'unsigned-byte)) (aver (typep inner-enclosed-profiles 'unsigned-byte)) - (multiple-value-prog1 + (unwind-protect (let* ((start-ticks (get-internal-ticks)) (*enclosed-ticks* 0) (*enclosed-consing* 0) @@ -172,7 +175,7 @@ (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 @@ -191,7 +194,9 @@ (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*))) + (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)))) @@ -217,20 +222,20 @@ ;;; 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))) (do-symbols (symbol package) (when (eq (symbol-package symbol) package) - (when (fboundp symbol) + (when (and (fboundp symbol) + (not (macro-function symbol)) + (not (special-operator-p symbol))) (funcall function symbol)) (let ((setf-name `(setf ,symbol))) (when (fboundp setf-name) @@ -239,14 +244,14 @@ ;;; Profile the named function, which should exist and not be profiled ;;; already. -(defun profile-1-unprofiled-function (name) - (declare #.*optimize-byte-compilation*) +(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*) + (without-package-locks + (setf (fdefinition name) + encapsulation-fun)) + (setf (gethash name *profiled-fun-name->info*) (make-profile-info :name name :encapsulated-fun encapsulated-fun :encapsulation-fun encapsulation-fun @@ -255,25 +260,24 @@ (values)))) ;;; Profile the named function. If already profiled, unprofile first. -(defun profile-1-function (name) - (declare #.*optimize-byte-compilation*) +(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) - (declare #.*optimize-byte-compilation*) - (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)) + (without-package-locks + (setf (fdefinition name) (profile-info-encapsulated-fun pinfo))) (warn "preserving current definition of redefined function ~S" name))) (t @@ -293,11 +297,10 @@ 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* + `(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 @@ -306,20 +309,18 @@ 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) + `(mapc-on-named-funs #'unprofile-1-fun ',names) `(unprofile-all))) (defun unprofile-all () - (declare #.*optimize-byte-compilation*) - (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)))) @@ -357,13 +358,12 @@ 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))) (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.~@ @@ -385,30 +385,69 @@ Lisp process." (sort time-info-list #'>= :key #'time-info-seconds)) + (print-profile-table time-info-list) - (format *trace-output* - "~& seconds | consed | calls | sec/call | name~@ - ------------------------------------------------------~%") + (when no-call-name-list + (format *trace-output* + "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%" + (sort no-call-name-list #'string< + :key (lambda (name) + (symbol-name (fun-name-block-name name)))))) + + (values))) + + +(defun print-profile-table (time-info-list) + (let ((total-seconds 0.0) + (total-consed 0) + (total-calls 0) + (seconds-width (length "seconds")) + (consed-width (length "consed")) + (calls-width (length "calls")) + (sec/call-width 10) + (name-width 6)) + (dolist (time-info time-info-list) + (incf total-seconds (time-info-seconds time-info)) + (incf total-consed (time-info-consing time-info)) + (incf total-calls (time-info-calls time-info))) + (setf seconds-width (max (length (format nil "~10,3F" total-seconds)) + seconds-width) + calls-width (max (length (format nil "~:D" total-calls)) + calls-width) + consed-width (max (length (format nil "~:D" total-consed)) + consed-width)) + + (flet ((dashes () + (dotimes (i (+ seconds-width consed-width calls-width + sec/call-width name-width + (* 5 3))) + (write-char #\- *trace-output*)) + (terpri *trace-output*))) + (format *trace-output* "~&~@{ ~v:@<~A~>~^|~}~%" + seconds-width "seconds" + (1+ consed-width) "consed" + (1+ calls-width) "calls" + (1+ sec/call-width) "sec/call" + (1+ name-width) "name") + + (dashes) - (let ((total-time 0.0) - (total-consed 0) - (total-calls 0)) (dolist (time-info time-info-list) - (incf total-time (time-info-seconds time-info)) - (incf total-calls (time-info-calls time-info)) - (incf total-consed (time-info-consing time-info)) - (format *trace-output* - "~10,3F | ~9:D | ~7:D | ~10,6F | ~S~%" - (time-info-seconds time-info) - (time-info-consing time-info) - (time-info-calls time-info) - (/ (time-info-seconds time-info) - (float (time-info-calls time-info))) - (time-info-name time-info))) - (format *trace-output* - "------------------------------------------------------~@ - ~10,3F | ~9:D | ~7:D | | Total~%" - total-time total-consed total-calls) + (format *trace-output* "~v,3F | ~v:D | ~v:D | ~10,6F | ~S~%" + seconds-width (time-info-seconds time-info) + consed-width (time-info-consing time-info) + calls-width (time-info-calls time-info) + (/ (time-info-seconds time-info) + (float (time-info-calls time-info))) + (time-info-name time-info))) + + (dashes) + + (format *trace-output* "~v,3F | ~v:D | ~v:D | | Total~%" + seconds-width total-seconds + consed-width total-consed + calls-width total-calls) + (format *trace-output* "~%estimated total profiling overhead: ~4,2F seconds~%" (* (overhead-total *overhead*) (float total-calls))) @@ -416,16 +455,8 @@ Lisp process." "~&overhead estimation parameters:~% ~Ss/call, ~Ss total profiling, ~Ss internal profiling~%" (overhead-call *overhead*) (overhead-total *overhead*) - (overhead-internal *overhead*))) - - (when no-call-name-list - (format *trace-output* - "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%" - (sort no-call-name-list #'string< - :key (lambda (name) - (symbol-name (function-name-block-name name)))))) + (overhead-internal *overhead*))))) - (values))) ;;;; overhead estimation @@ -450,6 +481,7 @@ Lisp process." (flet ((frob () (let ((start (get-internal-ticks)) (fun (symbol-function 'compute-overhead-aux))) + (declare (type function fun)) (dotimes (i *timer-overhead-iterations*) (funcall fun fun)) (/ (float (- (get-internal-ticks) start)) @@ -466,7 +498,7 @@ 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 @@ -485,5 +517,6 @@ Lisp process." ;;; different machine running at a different speed. We avoid this by ;;; erasing *CALL-OVERHEAD* whenever we save a .core file. (pushnew (lambda () - (makunbound '*overhead*)) + (without-package-locks + (makunbound '*overhead*))) *before-save-initializations*)