- (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))
+ (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))
- (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))
- (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))
- (unwind-protect
- (multiple-value-call encapsulated-fun
- (sb-c:%more-arg-values arg-context
- 0
- arg-count))
- (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*
- (fastbig-1+
- inner-enclosed-profiles)))))
+ (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))
+ (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))
+ (unwind-protect
+ (multiple-value-call encapsulated-fun
+ (sb-c:%more-arg-values arg-context
+ 0
+ arg-count))
+ (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*
+ (fastbig-1+
+ inner-enclosed-profiles)))))
- (do-symbols (symbol package)
- (when (eq (symbol-package symbol) package)
- (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)
- (funcall function setf-name)))))))))
+ (do-symbols (symbol package)
+ (when (eq (symbol-package symbol) package)
+ (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)
+ (funcall function setf-name)))))))))
- (when (gethash name *profiled-fun-name->info*)
- (warn "~S is already profiled, so unprofiling it first." name)
- (unprofile-1-fun name))
- (profile-1-unprofiled-fun name))
- (t
- (warn "ignoring undefined function ~S" name)))
+ (when (gethash name *profiled-fun-name->info*)
+ (warn "~S is already profiled, so unprofiling it first." name)
+ (unprofile-1-fun name))
+ (profile-1-unprofiled-fun name))
+ (t
+ (warn "ignoring undefined function ~S" name)))
- (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." name))))
+ (remhash name *profiled-fun-name->info*)
+ (if (eq (fdefinition name) (profile-info-encapsulation-fun pinfo))
+ (without-package-locks
+ (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." name))))
- (let ((total-time 0.0)
- (total-consed 0)
- (total-calls 0))
+(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)
+
- (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*
- "~%estimated total profiling overhead: ~4,2F seconds~%"
- (* (overhead-total *overhead*) (float total-calls)))
- (format *trace-output*
- "~&overhead estimation parameters:~% ~Ss/call, ~Ss total profiling, ~Ss internal profiling~%"
- (overhead-call *overhead*)
- (overhead-total *overhead*)
- (overhead-internal *overhead*)))
+ (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)))
- (progn
- (profile compute-overhead-aux)
- (setf total-overhead
- (- (frob) call-overhead)))
- (let* ((pinfo (gethash 'compute-overhead-aux
- *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*))))
- (unprofile compute-overhead-aux))
+ (progn
+ (profile compute-overhead-aux)
+ (setf total-overhead
+ (- (frob) call-overhead)))
+ (let* ((pinfo (gethash 'compute-overhead-aux
+ *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*))))
+ (unprofile compute-overhead-aux))
;;; It would be bad to compute *OVERHEAD*, save it into a .core file,
;;; 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.
;;; It would be bad to compute *OVERHEAD*, save it into a .core file,
;;; 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.