;;; 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)
\f
;;;; 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))
(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)
(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
(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))))
(etypecase name
(symbol (funcall function name))
(list
- ;; We call this just for the side effect of checking that
- ;; NAME is a legal function name:
- (fun-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)
(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
(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
(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)))
"~&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)))
\f
;;;; overhead estimation
(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))
;;; 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*)
projects / sbcl.git / blobdiff