X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprofile.lisp;h=97dba1fca12154f662314a1689b06eb5b29715db;hb=558e7ce44e6a8305474dc55adbdbc1f7119c9a5e;hp=87eab0bbeb72357190a90ad300c91df52cc5f038;hpb=ca379afc74fe525fd70035546d066de5f5ec874d;p=sbcl.git diff --git a/src/code/profile.lisp b/src/code/profile.lisp index 87eab0b..97dba1f 100644 --- a/src/code/profile.lisp +++ b/src/code/profile.lisp @@ -47,7 +47,11 @@ ;;; 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-fun-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 (missing-arg) :read-only t) (encapsulated-fun (missing-arg) :type function :read-only t) @@ -158,6 +162,7 @@ (let ((dticks 0) (dconsing 0) (inner-enclosed-profiles 0)) + (declare (optimize (safety 0))) (declare (type unsigned-byte dticks dconsing)) (declare (type unsigned-byte inner-enclosed-profiles)) (aver (typep dticks 'unsigned-byte)) @@ -190,9 +195,13 @@ (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*)))) + (let ((net-dconsing (fastbig- + (fastbig- dconsing + (pcounter-or-fixnum->integer + *enclosed-consing*)) + ;; three variables with value + ;; cells two bytes each. + (* 3 2 sb-vm:n-word-bytes)))) (fastbig-incf-pcounter-or-fixnum consing net-dconsing)) (fastbig-incf-pcounter-or-fixnum profiles inner-enclosed-profiles)))) @@ -229,7 +238,9 @@ (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) @@ -242,8 +253,9 @@ (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) + (without-package-locks + (setf (fdefinition name) + encapsulation-fun)) (setf (gethash name *profiled-fun-name->info*) (make-profile-info :name name :encapsulated-fun encapsulated-fun @@ -269,7 +281,8 @@ (cond (pinfo (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 @@ -377,30 +390,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))) @@ -408,16 +460,8 @@ Lisp process." "~&overhead estimation parameters:~% ~Ss/call, ~Ss total profiling, ~Ss internal profiling~%" (overhead-call *overhead*) (overhead-total *overhead*) - (overhead-internal *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 (fun-name-block-name name)))))) - - (values))) ;;;; overhead estimation @@ -477,6 +521,6 @@ Lisp process." ;;; 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 () - (makunbound '*overhead*)) - *before-save-initializations*) +(defun profile-deinit () + (without-package-locks + (makunbound '*overhead*)))