;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
;;; DAMAGE.
-;;; Statistical profiler for x86.
+;;; Statistical profiler.
;;; Overview:
;;;
;;;
;;; Random ideas for implementation:
;;;
-;;; * Show a disassembly of a function annotated with sampling
-;;; information.
-;;;
;;; * Space profiler. Sample when new pages are allocated instead of
;;; at SIGPROF.
;;;
(defun topological-sort (dag)
(let ((sorted ())
(dfn -1))
- (labels ((sort (v)
+ (labels ((rec-sort (v)
(setf (vertex-visited v) t)
(setf (vertex-dfn v) (incf dfn))
(dolist (e (vertex-edges v))
(unless (vertex-visited (edge-vertex e))
- (sort (edge-vertex e))))
+ (rec-sort (edge-vertex e))))
(push v sorted)))
- (map-vertices #'sort dag)
+ (map-vertices #'rec-sort dag)
(nreverse sorted))))
;;; Reduce graph G to a dag by coalescing strongly connected components
;;; comparison function Test. Assume each element to sort consists of
;;; Element-Size array slots, and that the slot Key-Offset contains
;;; the sort key.
-(defun qsort (vec &key (test #'<) (element-size 1) (key-offset 0)
+(defun qsort (vec &key (element-size 1) (key-offset 0)
(from 0) (to (- (length vec) element-size)))
- (declare (fixnum to from element-size)
- (function test))
+ (declare (type fixnum to from element-size key-offset))
+ (declare (type (simple-array address) vec))
(labels ((rotate (i j)
+ (declare (fixnum i j))
(loop repeat element-size
for i from i and j from j do
(rotatef (aref vec i) (aref vec j))))
(key (i)
(aref vec (+ i key-offset)))
- (sort (from to)
- (when (> to from)
+ (rec-sort (from to)
+ (declare (fixnum to from))
+ (when (> to from)
(let* ((mid (* element-size
(round (+ (/ from element-size)
(/ to element-size))
(i from)
(j (+ to element-size))
(p (key mid)))
- (declare (fixnum i j))
+ (declare (fixnum mid i j))
(rotate mid from)
(loop
(loop do (incf i element-size)
until (or (> i to)
- (funcall test p (key i))))
+ ;; QSORT used to take a test
+ ;; parameter which was funcalled
+ ;; here. This caused some consing,
+ ;; which is problematic since
+ ;; QSORT is indirectly called in
+ ;; an after-gc-hook. So just
+ ;; hardcode >, which would've been
+ ;; used for the test anyway.
+ ;; --JES, 2004-07-09
+ (> p (key i))))
(loop do (decf j element-size)
until (or (<= j from)
- (funcall test (key j) p)))
+ ;; As above.
+ (> (key j) p)))
(when (< j i) (return))
(rotate i j))
(rotate from j)
- (sort from (- j element-size))
- (sort i to)))))
- (sort from to)
+ (rec-sort from (- j element-size))
+ (rec-sort i to)))))
+ (rec-sort from to)
vec))
\f
(deftype address ()
"Type used for addresses, for instance, program counters,
code start/end locations etc."
- '(unsigned-byte 32))
+ '(unsigned-byte #+alpha 64 #-alpha 32))
(defconstant +unknown-address+ 0
"Constant representing an address that cannot be determined.")
`(let ((*sampling* ,on))
,@body))
-(defun sort-samples (&key test (key :pc))
+(defun sort-samples (&key (key :pc))
"Sort *Samples* using comparison Test. Key must be one of
:Pc or :Return-Pc for sorting by pc or return pc."
(declare (type (member :pc :return-pc) key))
(qsort *samples*
:from 0
:to (- *samples-index* +sample-size+)
- :test test
:element-size +sample-size+
:key-offset (if (eq key :pc) 0 1))))
(fp (sb-vm::context-register scp #.sb-vm::ebp-offset))
(ra (sap-ref-32 (int-sap fp)
(- (* (1+ sb-vm::return-pc-save-offset)
- sb-vm::n-word-bytes)))))
+ sb-vm::n-word-bytes)))))
(record (sap-int pc-ptr))
(record ra)))))))
#-x86
(defun sigprof-handler (signal code scp)
- (declare (ignore signal code scp))
- (error "Implement me."))
+ (declare (ignore signal code))
+ (when (and *sampling*
+ (< *samples-index* (length *samples*)))
+ (sb-sys:without-gcing
+ (with-alien ((scp (* os-context-t) :local scp))
+ (locally (declare (optimize (inhibit-warnings 2)))
+ (let* ((pc-ptr (sb-vm:context-pc scp))
+ (fp (sb-vm::context-register scp #.sb-vm::cfp-offset))
+ (ra (sap-ref-32
+ (int-sap fp)
+ (* sb-vm::lra-save-offset sb-vm::n-word-bytes))))
+ (record (sap-int pc-ptr))
+ (record ra)))))))
;;; Map function FN over code objects in dynamic-space. FN is called
;;; with two arguments, the object and its size in bytes.
;;; dynamic-space code objects. KEY being :PC means adjust pcs.
(defun adjust-samples (key)
(declare (type (member :pc :return-pc) key))
- (sort-samples :test #'> :key key)
+ (sort-samples :key key)
(let ((sidx 0)
(offset (if (eq key :pc) 0 1)))
(declare (type sb-impl::index sidx))
(dolist (info *dynamic-space-code-info*)
(setf (dyninfo-new-start info)
(code-start (dyninfo-code info))))
- (adjust-samples :pc)
- (adjust-samples :return-pc)
+ (progn
+ (adjust-samples :pc)
+ (adjust-samples :return-pc))
(dolist (info *dynamic-space-code-info*)
(let ((size (- (dyninfo-end info) (dyninfo-start info))))
(setf (dyninfo-start info) (dyninfo-new-start info))
;;; Return a CALL-GRAPH structure for the current contents of
;;; *SAMPLES*. The result contain a list of nodes sorted by self-time
-;;; in the FLAT-NODES slot, and a dag in Vertices, with call cycles
-;;; reduced to Cycle structures.
+;;; in the FLAT-NODES slot, and a dag in VERTICES, with call cycles
+;;; reduced to CYCLE structures.
(defun make-call-graph ()
(stop-profiling)
(show-progress "~&Computing call graph ")
(format t "~& Count % Parts~%")
(do-vertices (node call-graph)
(when (cycle-p node)
- (flet ((print (indent index count percent name)
+ (flet ((print-info (indent index count percent name)
(format t "~&~6d ~5,1f ~11@t ~V@t ~s [~d]~%"
count percent indent name index)))
(print-separator)
(samples-percent call-graph (cycle-count node))
(node-name node))
(dolist (v (vertex-scc-vertices node))
- (print 4 (node-index v) (node-count v)
- (samples-percent call-graph (node-count v))
- (node-name v))))))
+ (print-info 4 (node-index v) (node-count v)
+ (samples-percent call-graph (node-count v))
+ (node-name v))))))
(print-separator)
(format t "~2%")))
(print-cycles call-graph)
(flet ((find-call (from to)
(find to (node-edges from) :key #'call-vertex))
- (print (indent index count percent name)
+ (print-info (indent index count percent name)
(format t "~&~6d ~5,1f ~11@t ~V@t ~s [~d]~%"
count percent indent name index)))
(format t "~& Callers~%")
;; Print caller information.
(dolist (caller (node-callers node))
(let ((call (find-call caller node)))
- (print 4 (node-index caller)
- (call-count call)
- (samples-percent call-graph (call-count call))
- (node-name caller))))
+ (print-info 4 (node-index caller)
+ (call-count call)
+ (samples-percent call-graph (call-count call))
+ (node-name caller))))
;; Print the node itself.
(format t "~&~6d ~5,1f ~6d ~5,1f ~s [~d]~%"
(node-count node)
(node-index node))
;; Print callees.
(do-edges (call called node)
- (print 4 (node-index called)
- (call-count call)
- (samples-percent call-graph (call-count call))
- (node-name called))))
+ (print-info 4 (node-index called)
+ (call-count call)
+ (samples-percent call-graph (call-count call))
+ (node-name called))))
(print-separator)
(format t "~2%")
(print-flat call-graph :stream stream :max max
((nil)))
graph))
-;;;; Silly Examples
+;;; Interface to DISASSEMBLE
+
+(defun add-disassembly-profile-note (chunk stream dstate)
+ (declare (ignore chunk stream))
+ (unless (zerop *samples-index*)
+ (let* ((location
+ (+ (sb-disassem::seg-virtual-location
+ (sb-disassem:dstate-segment dstate))
+ (sb-disassem::dstate-cur-offs dstate)))
+ (samples (loop for x from 0 below *samples-index* by +sample-size+
+ summing (if (= (aref *samples* x) location)
+ 1
+ 0))))
+ (unless (zerop samples)
+ (sb-disassem::note (format nil "~A/~A samples"
+ samples (/ *samples-index* +sample-size+))
+ dstate)))))
+
+(pushnew 'add-disassembly-profile-note sb-disassem::*default-dstate-hooks*)
+
+;;; silly examples
(defun test-0 (n &optional (depth 0))
(declare (optimize (debug 3)))
(with-profiling (:reset t :max-samples 1000 :report :graph)
(test-0 7)))
-;;; End of file.
+
+;;; provision
+(provide 'sb-sprof)
+
+;;; end of file
projects / sbcl.git / blobdiff