- (let ((rx (vertex-root x))
- (ry (vertex-root y)))
- (if (< (vertex-dfn rx) (vertex-dfn ry))
- rx
- ry)))
- (in-component (v)
- (aref in-component (vertex-dfn v)))
- ((setf in-component) (in v)
- (setf (aref in-component (vertex-dfn v)) in))
- (vertex-> (x y)
- (> (vertex-dfn x) (vertex-dfn y)))
- (visit (v)
- (setf (vertex-dfn v) (incf dfn)
- (in-component v) nil
- (vertex-root v) v
- (vertex-visited v) t)
- (do-edges (e w v)
- (unless (vertex-visited w)
- (visit w))
- (unless (in-component w)
- (setf (vertex-root v) (min-root v w))))
- (if (eq v (vertex-root v))
- (loop while (and stack (vertex-> (car stack) v))
- as w = (pop stack)
- collect w into this-component
- do (setf (in-component w) t)
- finally
- (setf (in-component v) t)
- (push (cons v this-component) components))
- (push v stack))))
+ (let ((rx (vertex-root x))
+ (ry (vertex-root y)))
+ (if (< (vertex-dfn rx) (vertex-dfn ry))
+ rx
+ ry)))
+ (in-component (v)
+ (aref in-component (vertex-dfn v)))
+ ((setf in-component) (in v)
+ (setf (aref in-component (vertex-dfn v)) in))
+ (vertex-> (x y)
+ (> (vertex-dfn x) (vertex-dfn y)))
+ (visit (v)
+ (setf (vertex-dfn v) (incf dfn)
+ (in-component v) nil
+ (vertex-root v) v
+ (vertex-visited v) t)
+ (do-edges (e w v)
+ (unless (vertex-visited w)
+ (visit w))
+ (unless (in-component w)
+ (setf (vertex-root v) (min-root v w))))
+ (if (eq v (vertex-root v))
+ (loop while (and stack (vertex-> (car stack) v))
+ as w = (pop stack)
+ collect w into this-component
+ do (setf (in-component w) t)
+ finally
+ (setf (in-component v) t)
+ (push (cons v this-component) components))
+ (push v stack))))
- (setf (vertex-visited v) t)
- (setf (vertex-dfn v) (incf dfn))
- (dolist (e (vertex-edges v))
- (unless (vertex-visited (edge-vertex e))
- (rec-sort (edge-vertex e))))
- (push v sorted)))
+ (setf (vertex-visited v) t)
+ (setf (vertex-dfn v) (incf dfn))
+ (dolist (e (vertex-edges v))
+ (unless (vertex-visited (edge-vertex e))
+ (rec-sort (edge-vertex e))))
+ (push v sorted)))
(sb-int:collect ((sccs) (trivial))
(dolist (c (strong-components (graph-vertices graph)))
(if (or (cdr c) (self-cycle-p (car c)))
(sb-int:collect ((sccs) (trivial))
(dolist (c (strong-components (graph-vertices graph)))
(if (or (cdr c) (self-cycle-p (car c)))
- (let ((name (sb-int::symbolicate 'aa- name)))
- `(defun ,name (item tree &key
- (test-< #'<) (test-= #'=)
- (node-key #'identity) (item-key #'identity))
- (let ((.item-key. (funcall item-key item)))
- (flet ((item-< (node)
- (funcall test-< .item-key.
- (funcall node-key (aa-data node))))
- (item-= (node)
- (funcall test-= .item-key.
- (funcall node-key (aa-data node)))))
- (declare (inline item-< item-=))
- ,@body))))))
-
+ (let ((name (sb-int::symbolicate 'aa- name)))
+ `(defun ,name (item tree &key
+ (test-< #'<) (test-= #'=)
+ (node-key #'identity) (item-key #'identity))
+ (let ((.item-key. (funcall item-key item)))
+ (flet ((item-< (node)
+ (funcall test-< .item-key.
+ (funcall node-key (aa-data node))))
+ (item-= (node)
+ (funcall test-= .item-key.
+ (funcall node-key (aa-data node)))))
+ (declare (inline item-< item-=))
+ ,@body))))))
+
- (cond ((eq aa *null-node*)
- (setq aa (make-aa-node :data item
- :left *null-node*
- :right *null-node*)))
- ((item-= aa)
- (return-from insert-into aa))
- ((item-< aa)
- (setf (aa-left aa) (insert-into (aa-left aa))))
- (t
- (setf (aa-right aa) (insert-into (aa-right aa)))))
- (split (skew aa))))
+ (cond ((eq aa *null-node*)
+ (setq aa (make-aa-node :data item
+ :left *null-node*
+ :right *null-node*)))
+ ((item-= aa)
+ (return-from insert-into aa))
+ ((item-< aa)
+ (setf (aa-left aa) (insert-into (aa-left aa))))
+ (t
+ (setf (aa-right aa) (insert-into (aa-right aa)))))
+ (split (skew aa))))
- (unless (eq aa *null-node*)
- (setq last-node aa)
- (if (item-< aa)
- (setf (aa-left aa) (remove-from (aa-left aa)))
- (progn
- (setq deleted-node aa)
- (setf (aa-right aa) (remove-from (aa-right aa)))))
- (cond ((eq aa last-node)
- ;;
- ;; If at the bottom of the tree, and item
- ;; is present, delete it.
- (when (and (not (eq deleted-node *null-node*))
- (item-= deleted-node))
- (setf (aa-data deleted-node) (aa-data aa))
- (setq deleted-node *null-node*)
- (setq aa (aa-right aa))))
- ;;
- ;; Otherwise not at bottom of tree; rebalance.
- ((or (< (aa-level (aa-left aa))
- (1- (aa-level aa)))
- (< (aa-level (aa-right aa))
- (1- (aa-level aa))))
- (decf (aa-level aa))
- (when (> (aa-level (aa-right aa)) (aa-level aa))
- (setf (aa-level (aa-right aa)) (aa-level aa)))
- (setq aa (skew aa))
- (setf (aa-right aa) (skew (aa-right aa)))
- (setf (aa-right (aa-right aa))
- (skew (aa-right (aa-right aa))))
- (setq aa (split aa))
- (setf (aa-right aa) (split (aa-right aa))))))
- aa))
- (setf (aa-tree-root tree)
- (remove-from (aa-tree-root tree))))))
+ (unless (eq aa *null-node*)
+ (setq last-node aa)
+ (if (item-< aa)
+ (setf (aa-left aa) (remove-from (aa-left aa)))
+ (progn
+ (setq deleted-node aa)
+ (setf (aa-right aa) (remove-from (aa-right aa)))))
+ (cond ((eq aa last-node)
+ ;;
+ ;; If at the bottom of the tree, and item
+ ;; is present, delete it.
+ (when (and (not (eq deleted-node *null-node*))
+ (item-= deleted-node))
+ (setf (aa-data deleted-node) (aa-data aa))
+ (setq deleted-node *null-node*)
+ (setq aa (aa-right aa))))
+ ;;
+ ;; Otherwise not at bottom of tree; rebalance.
+ ((or (< (aa-level (aa-left aa))
+ (1- (aa-level aa)))
+ (< (aa-level (aa-right aa))
+ (1- (aa-level aa))))
+ (decf (aa-level aa))
+ (when (> (aa-level (aa-right aa)) (aa-level aa))
+ (setf (aa-level (aa-right aa)) (aa-level aa)))
+ (setq aa (skew aa))
+ (setf (aa-right aa) (skew (aa-right aa)))
+ (setf (aa-right (aa-right aa))
+ (skew (aa-right (aa-right aa))))
+ (setq aa (split aa))
+ (setf (aa-right aa) (split (aa-right aa))))))
+ aa))
+ (setf (aa-tree-root tree)
+ (remove-from (aa-tree-root tree))))))
- (cond ((eq current *null-node*)
- (return (values nil nil)))
- ((item-= current)
- (return (values (aa-data current) t)))
- ((item-< current)
- (setq current (aa-left current)))
- (t
- (setq current (aa-right current))))))))
+ (cond ((eq current *null-node*)
+ (return (values nil nil)))
+ ((item-= current)
+ (return (values (aa-data current) t)))
+ ((item-< current)
+ (setq current (aa-left current)))
+ (t
+ (setq current (aa-right current))))))))
- (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)))
- (rec-sort (from to)
- (declare (fixnum to from))
- (when (> to from)
- (let* ((mid (* element-size
- (round (+ (/ from element-size)
- (/ to element-size))
- 2)))
- (i from)
- (j (+ to element-size))
- (p (key mid)))
- (declare (fixnum mid i j))
- (rotate mid from)
- (loop
- (loop do (incf i element-size)
- until (or (> i to)
- ;; 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)
- ;; As above.
- (> (key j) p)))
- (when (< j i) (return))
- (rotate i j))
- (rotate from j)
- (rec-sort from (- j element-size))
- (rec-sort i to)))))
+ (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)))
+ (rec-sort (from to)
+ (declare (fixnum to from))
+ (when (> to from)
+ (let* ((mid (* element-size
+ (round (+ (/ from element-size)
+ (/ to element-size))
+ 2)))
+ (i from)
+ (j (+ to element-size))
+ (p (key mid)))
+ (declare (fixnum mid i j))
+ (rotate mid from)
+ (loop
+ (loop do (incf i element-size)
+ until (or (> i to)
+ ;; 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)
+ ;; As above.
+ (> (key j) p)))
+ (when (< j i) (return))
+ (rotate i j))
+ (rotate from j)
+ (rec-sort from (- j element-size))
+ (rec-sort i to)))))
;; the value of *Sample-Interval* at the time the graph was created
(sample-interval (sb-impl::missing-arg) :type number)
;; number of samples taken
;; the value of *Sample-Interval* at the time the graph was created
(sample-interval (sb-impl::missing-arg) :type number)
;; number of samples taken
;;; sampled. The edges of a node are CALL structures that represent
;;; functions called from a given node.
(defstruct (node (:include vertex)
;;; sampled. The edges of a node are CALL structures that represent
;;; functions called from a given node.
(defstruct (node (:include vertex)
(defmethod print-object ((call call) stream)
(print-unreadable-object (call stream :type t :identity t)
(format stream "~s [~d]" (node-name (call-vertex call))
(defmethod print-object ((call call) stream)
(print-unreadable-object (call stream :type t :identity t)
(format stream "~s [~d]" (node-name (call-vertex call))
- :from 0
- :to (- *samples-index* +sample-size+)
- :element-size +sample-size+
- :key-offset key-offset)))
+ :from 0
+ :to (- *samples-index* +sample-size+)
+ :element-size +sample-size+
+ :key-offset key-offset)))
- (when (and *sampling*
- (< *samples-index* (length *samples*)))
- (sb-sys:without-gcing
- (locally (declare (optimize (inhibit-warnings 2)))
- (with-alien ((scp (* os-context-t) :local scp))
- ;; For some reason completely bogus small values for the
- ;; frame pointer are returned every now and then, leading
- ;; to segfaults. Try to avoid these cases.
- ;;
- ;; FIXME: Do a more thorough sanity check on ebp, or figure
- ;; out why this is happening.
- ;; -- JES, 2005-01-11
- (when (< (sb-vm::context-register scp #.sb-vm::ebp-offset)
- 4096)
- (dotimes (i +sample-size+)
- (record 0))
- (return-from sigprof-handler nil))
- (let* ((pc-ptr (sb-vm:context-pc scp))
- (fp (sb-vm::context-register scp #.sb-vm::ebp-offset)))
- (record (sap-int pc-ptr))
- (let ((fp (int-sap fp))
- ra)
- (dotimes (i (1- +sample-size+))
- (cond (fp
- (setf (values ra fp)
- (sb-di::x86-call-context fp :depth i))
- (record (if ra
- (sap-int ra)
- 0)))
- (t
- (record 0)))))))))))
+ (sb-sys:with-interrupts
+ (when (and *sampling*
+ (< *samples-index* (length *samples*)))
+ (sb-sys:without-gcing
+ (locally (declare (optimize (inhibit-warnings 2)))
+ (with-alien ((scp (* os-context-t) :local scp))
+ ;; For some reason completely bogus small values for the
+ ;; frame pointer are returned every now and then, leading
+ ;; to segfaults. Try to avoid these cases.
+ ;;
+ ;; FIXME: Do a more thorough sanity check on ebp, or figure
+ ;; out why this is happening.
+ ;; -- JES, 2005-01-11
+ (when (< (sb-vm::context-register scp #.sb-vm::ebp-offset)
+ 4096)
+ (dotimes (i +sample-size+)
+ (record 0))
+ (return-from sigprof-handler nil))
+ (let* ((pc-ptr (sb-vm:context-pc scp))
+ (fp (sb-vm::context-register scp #.sb-vm::ebp-offset)))
+ (record (sap-int pc-ptr))
+ (let ((fp (int-sap fp))
+ ra)
+ (dotimes (i (1- +sample-size+))
+ (cond (fp
+ (setf (values ra fp)
+ (sb-di::x86-call-context fp :depth i))
+ (record (if ra
+ (sap-int ra)
+ 0)))
+ (t
+ (record 0))))))))))))
;; FIXME: On non-x86 platforms we don't yet walk the call stack deeper
;; than one level.
#-(or x86 x86-64)
(defun sigprof-handler (signal code scp)
(declare (ignore signal code))
;; FIXME: On non-x86 platforms we don't yet walk the call stack deeper
;; than one level.
#-(or x86 x86-64)
(defun sigprof-handler (signal code scp)
(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-word
- (int-sap fp)
- (* sb-vm::lra-save-offset sb-vm::n-word-bytes))))
- (record (sap-int pc-ptr))
- (record ra)))))))
+ (sb-sys:with-interrupts
+ (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-word
+ (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.
(defun map-dynamic-space-code (fn)
(flet ((call-if-code (obj obj-type size)
;;; Map function FN over code objects in dynamic-space. FN is called
;;; with two arguments, the object and its size in bytes.
(defun map-dynamic-space-code (fn)
(flet ((call-if-code (obj obj-type size)
- (declare (ignore obj-type))
- (when (sb-kernel:code-component-p obj)
- (funcall fn obj size))))
+ (declare (ignore obj-type))
+ (when (sb-kernel:code-component-p obj)
+ (funcall fn obj size))))
(defun code-bounds (code)
(declare (type sb-kernel:code-component code))
(let* ((start (code-start code))
(defun code-bounds (code)
(declare (type sb-kernel:code-component code))
(let* ((start (code-start code))
- (declare (ignore size))
- (multiple-value-bind (start end)
- (code-bounds code)
- (push (make-dyninfo code start end)
- *dynamic-space-code-info*))))
+ (declare (ignore size))
+ (multiple-value-bind (start end)
+ (code-bounds code)
+ (push (make-dyninfo code start end)
+ *dynamic-space-code-info*))))
(declare (type sb-impl::index sidx))
(dolist (info *dynamic-space-code-info*)
(unless (= (dyninfo-new-start info) (dyninfo-start info))
(declare (type sb-impl::index sidx))
(dolist (info *dynamic-space-code-info*)
(unless (= (dyninfo-new-start info) (dyninfo-start info))
- (let ((pos (do ((i sidx (+ i +sample-size+)))
- ((= i *samples-index*) nil)
- (declare (type sb-impl::index i))
- (when (<= (dyninfo-start info)
- (aref *samples* (+ i offset))
- (dyninfo-end info))
- (return i)))))
- (when pos
- (setq sidx pos)
- (loop with delta = (- (dyninfo-new-start info)
- (dyninfo-start info))
- for j from sidx below *samples-index* by +sample-size+
- as pc = (aref *samples* (+ j offset))
- while (<= (dyninfo-start info) pc (dyninfo-end info)) do
- (incf (aref *samples* (+ j offset)) delta)
- (incf sidx +sample-size+))))))))
+ (let ((pos (do ((i sidx (+ i +sample-size+)))
+ ((= i *samples-index*) nil)
+ (declare (type sb-impl::index i))
+ (when (<= (dyninfo-start info)
+ (aref *samples* (+ i offset))
+ (dyninfo-end info))
+ (return i)))))
+ (when pos
+ (setq sidx pos)
+ (loop with delta = (- (dyninfo-new-start info)
+ (dyninfo-start info))
+ for j from sidx below *samples-index* by +sample-size+
+ as pc = (aref *samples* (+ j offset))
+ while (<= (dyninfo-start info) pc (dyninfo-end info)) do
+ (incf (aref *samples* (+ j offset)) delta)
+ (incf sidx +sample-size+))))))))
It true, call Reset at the beginning."
(declare (type report-type report))
`(let ((*sample-interval* ,sample-interval)
It true, call Reset at the beginning."
(declare (type report-type report))
`(let ((*sample-interval* ,sample-interval)
- (when (>= *samples-index* (length *samples*))
- (return))
- ,@(when show-progress
- `((format t "~&===> ~d of ~d samples taken.~%"
- (/ *samples-index* +sample-size+)
- *max-samples*)))
- (let ((.last-index. *samples-index*))
- ,@body
- (when (= .last-index. *samples-index*)
- (warn "No sampling progress; possibly a profiler bug.")
- (return))))
+ (when (>= *samples-index* (length *samples*))
+ (return))
+ ,@(when show-progress
+ `((format t "~&===> ~d of ~d samples taken.~%"
+ (/ *samples-index* +sample-size+)
+ *max-samples*)))
+ (let ((.last-index. *samples-index*))
+ ,@body
+ (when (= .last-index. *samples-index*)
+ (warn "No sampling progress; possibly a profiler bug.")
+ (return))))
(stop-profiling)
,@(when report-p `((report :type ,report)))))
(defun start-profiling (&key (max-samples *max-samples*)
(stop-profiling)
,@(when report-p `((report :type ,report)))))
(defun start-profiling (&key (max-samples *max-samples*)
- (multiple-value-bind (secs rest)
- (truncate sample-interval)
- (values secs (truncate (* rest 1000000))))
+ (multiple-value-bind (secs rest)
+ (truncate sample-interval)
+ (values secs (truncate (* rest 1000000))))
- (cdf (sb-di::compiled-debug-fun-compiler-debug-fun info))
- (start-offset (sb-c::compiled-debug-fun-start-pc cdf))
- (end-offset (sb-c::compiled-debug-fun-elsewhere-pc cdf))
- (component (sb-di::compiled-debug-fun-component info))
- (start-pc (code-start component)))
+ (cdf (sb-di::compiled-debug-fun-compiler-debug-fun info))
+ (start-offset (sb-c::compiled-debug-fun-start-pc cdf))
+ (end-offset (sb-c::compiled-debug-fun-elsewhere-pc cdf))
+ (component (sb-di::compiled-debug-fun-component info))
+ (start-pc (code-start component)))
(declare (type address pc))
(let ((ptr (sb-di::component-ptr-from-pc (int-sap pc))))
(cond ((sap= ptr (int-sap 0))
(declare (type address pc))
(let ((ptr (sb-di::component-ptr-from-pc (int-sap pc))))
(cond ((sap= ptr (int-sap 0))
- (let ((name (foreign-symbol-in-address (int-sap pc))))
- (when name
- (format nil "foreign function ~a" name))))
- (t
- (let* ((code (sb-di::component-from-component-ptr ptr))
- (code-header-len (* (sb-kernel:get-header-data code)
- sb-vm:n-word-bytes))
- (pc-offset (- pc
- (- (sb-kernel:get-lisp-obj-address code)
- sb-vm:other-pointer-lowtag)
- code-header-len))
- (df (ignore-errors (sb-di::debug-fun-from-pc code
- pc-offset))))
- (or df
- code))))))
-
+ (let ((name (sap-foreign-symbol (int-sap pc))))
+ (when name
+ (format nil "foreign function ~a" name))))
+ (t
+ (let* ((code (sb-di::component-from-component-ptr ptr))
+ (code-header-len (* (sb-kernel:get-header-data code)
+ sb-vm:n-word-bytes))
+ (pc-offset (- pc
+ (- (sb-kernel:get-lisp-obj-address code)
+ sb-vm:other-pointer-lowtag)
+ code-header-len))
+ (df (ignore-errors (sb-di::debug-fun-from-pc code
+ pc-offset))))
+ (or df
+ code))))))
+
- (when info
- (let* ((new (make-node info))
- (found (gethash (node-name new) *name->node*)))
- (cond (found
- (setf (node-start-pc found)
- (min (node-start-pc found) (node-start-pc new)))
- (setf (node-end-pc found)
- (max (node-end-pc found) (node-end-pc new)))
- found)
- (t
- (setf (gethash (node-name new) *name->node*) new)
- (tree-insert new)
- new)))))))
+ (when info
+ (let* ((new (make-node info))
+ (found (gethash (node-name new) *name->node*)))
+ (cond (found
+ (setf (node-start-pc found)
+ (min (node-start-pc found) (node-start-pc new)))
+ (setf (node-end-pc found)
+ (max (node-end-pc found) (node-end-pc new)))
+ found)
+ (t
+ (setf (gethash (node-name new) *name->node*) new)
+ (tree-insert new)
+ new)))))))
;;; Value is a CALL-GRAPH for the current contents of *SAMPLES*.
(defun make-call-graph-1 (depth)
(let ((elsewhere-count 0)
;;; Value is a CALL-GRAPH for the current contents of *SAMPLES*.
(defun make-call-graph-1 (depth)
(let ((elsewhere-count 0)
- as pc = (aref *samples* i)
- as return-pc = (aref *samples* (1+ i))
- as callee = (lookup-node pc)
- as caller =
- (when (and callee (/= return-pc +unknown-address+))
- (let ((caller (lookup-node return-pc)))
- (when caller
- caller)))
- do
- (when (and *show-progress* (plusp i))
- (cond ((zerop (mod i 1000))
- (show-progress "~d" i))
- ((zerop (mod i 100))
- (show-progress "."))))
- (when (< (mod i +sample-size+) depth)
- (when (= (mod i +sample-size+) 0)
- (setf visited-nodes nil)
- (cond (callee
- (incf (node-accrued-count callee))
- (incf (node-count callee)))
- (t
- (incf elsewhere-count))))
- (when callee
- (push callee visited-nodes))
- (when caller
- (unless (member caller visited-nodes)
- (incf (node-accrued-count caller)))
- (when callee
- (let ((call (find callee (node-edges caller)
- :key #'call-vertex)))
- (pushnew caller (node-callers callee))
- (if call
- (unless (member caller visited-nodes)
- (incf (call-count call)))
- (push (make-call callee) (node-edges caller))))))))
+ as pc = (aref *samples* i)
+ as return-pc = (aref *samples* (1+ i))
+ as callee = (lookup-node pc)
+ as caller =
+ (when (and callee (/= return-pc +unknown-address+))
+ (let ((caller (lookup-node return-pc)))
+ (when caller
+ caller)))
+ do
+ (when (and *show-progress* (plusp i))
+ (cond ((zerop (mod i 1000))
+ (show-progress "~d" i))
+ ((zerop (mod i 100))
+ (show-progress "."))))
+ (when (< (mod i +sample-size+) depth)
+ (when (= (mod i +sample-size+) 0)
+ (setf visited-nodes nil)
+ (cond (callee
+ (incf (node-accrued-count callee))
+ (incf (node-count callee)))
+ (t
+ (incf elsewhere-count))))
+ (when callee
+ (push callee visited-nodes))
+ (when caller
+ (unless (member caller visited-nodes)
+ (incf (node-accrued-count caller)))
+ (when callee
+ (let ((call (find callee (node-edges caller)
+ :key #'call-vertex)))
+ (pushnew caller (node-callers callee))
+ (if call
+ (unless (member caller visited-nodes)
+ (incf (call-count call)))
+ (push (make-call callee) (node-edges caller))))))))
- (loop for node in sorted-nodes and i from 1 do
- (setf (node-index node) i))
- (%make-call-graph :nsamples (/ *samples-index* +sample-size+)
- :sample-interval *sample-interval*
- :elsewhere-count elsewhere-count
- :vertices sorted-nodes)))))
+ (loop for node in sorted-nodes and i from 1 do
+ (setf (node-index node) i))
+ (%make-call-graph :nsamples (/ *samples-index* +sample-size+)
+ :sample-interval *sample-interval*
+ :elsewhere-count elsewhere-count
+ :vertices sorted-nodes)))))
;;; Reduce CALL-GRAPH to a dag, creating CYCLE structures for call
;;; cycles.
(defun reduce-call-graph (call-graph)
(let ((cycle-no 0))
(flet ((make-one-cycle (vertices edges)
;;; Reduce CALL-GRAPH to a dag, creating CYCLE structures for call
;;; cycles.
(defun reduce-call-graph (call-graph)
(let ((cycle-no 0))
(flet ((make-one-cycle (vertices edges)
(show-progress "~&Computing call graph ")
(let ((call-graph (without-gcing (make-call-graph-1 depth))))
(setf (call-graph-flat-nodes call-graph)
(show-progress "~&Computing call graph ")
(let ((call-graph (without-gcing (make-call-graph-1 depth))))
(setf (call-graph-flat-nodes call-graph)
(show-progress "~&Finding cycles")
(reduce-call-graph call-graph)
(show-progress "~&Propagating counts")
(show-progress "~&Finding cycles")
(reduce-call-graph call-graph)
(show-progress "~&Propagating counts")
(format t "~&~V,,,V<~>~%" length char))
(defun samples-percent (call-graph count)
(format t "~&~V,,,V<~>~%" length char))
(defun samples-percent (call-graph count)
(format t "~2&Number of samples: ~d~%~
Sample interval: ~f seconds~%~
Total sampling time: ~f seconds~%~
Number of cycles: ~d~2%"
(format t "~2&Number of samples: ~d~%~
Sample interval: ~f seconds~%~
Total sampling time: ~f seconds~%~
Number of cycles: ~d~2%"
- (*print-pretty* nil)
- (total-count 0)
- (total-percent 0)
- (min-count (if min-percent
- (round (* (/ min-percent 100.0)
- (call-graph-nsamples call-graph)))
- 0)))
+ (*print-pretty* nil)
+ (total-count 0)
+ (total-percent 0)
+ (min-count (if min-percent
+ (round (* (/ min-percent 100.0)
+ (call-graph-nsamples call-graph)))
+ 0)))
(when print-header
(print-call-graph-header call-graph))
(format t "~& Self Cumul Total~%")
(format t "~& Nr Count % Count % Count % Function~%")
(print-separator)
(let ((elsewhere-count (call-graph-elsewhere-count call-graph))
(when print-header
(print-call-graph-header call-graph))
(format t "~& Self Cumul Total~%")
(format t "~& Nr Count % Count % Count % Function~%")
(print-separator)
(let ((elsewhere-count (call-graph-elsewhere-count call-graph))
- (when (or (and max (> (incf i) max))
- (< (node-count node) min-count))
- (return))
- (let* ((count (node-count node))
- (percent (samples-percent call-graph count))
- (accrued-count (node-accrued-count node))
- (accrued-percent (samples-percent call-graph accrued-count)))
- (incf total-count count)
- (incf total-percent percent)
- (format t "~&~4d ~6d ~5,1f ~6d ~5,1f ~6d ~5,1f ~s~%"
- (node-index node)
- count
- percent
- accrued-count
- accrued-percent
- total-count
- total-percent
- (node-name node))
- (finish-output)))
+ (when (or (and max (> (incf i) max))
+ (< (node-count node) min-count))
+ (return))
+ (let* ((count (node-count node))
+ (percent (samples-percent call-graph count))
+ (accrued-count (node-accrued-count node))
+ (accrued-percent (samples-percent call-graph accrued-count)))
+ (incf total-count count)
+ (incf total-percent percent)
+ (format t "~&~4d ~6d ~5,1f ~6d ~5,1f ~6d ~5,1f ~s~%"
+ (node-index node)
+ count
+ percent
+ accrued-count
+ accrued-percent
+ total-count
+ total-percent
+ (node-name node))
+ (finish-output)))
- (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)
- (format t "~&~6d ~5,1f ~a...~%"
- (node-count node)
- (samples-percent call-graph (cycle-count node))
- (node-name node))
- (dolist (v (vertex-scc-vertices node))
- (print-info 4 (node-index v) (node-count v)
+ (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)
+ (format t "~&~6d ~5,1f ~a...~%"
+ (node-count node)
+ (samples-percent call-graph (cycle-count node))
+ (node-name node))
+ (dolist (v (vertex-scc-vertices node))
+ (print-info 4 (node-index v) (node-count v)
(print-call-graph-header call-graph)
(print-cycles call-graph)
(flet ((find-call (from to)
(print-call-graph-header call-graph)
(print-cycles call-graph)
(flet ((find-call (from to)
- (find to (node-edges from) :key #'call-vertex))
- (print-info (indent index count percent name)
- (format t "~&~6d ~5,1f ~11@t ~V@t ~s [~d]~%"
- count percent indent name index)))
+ (find to (node-edges from) :key #'call-vertex))
+ (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~%")
(format t "~& Cumul. Function~%")
(format t "~& Count % Count % Callees~%")
(do-vertices (node call-graph)
(format t "~& Callers~%")
(format t "~& Cumul. Function~%")
(format t "~& Count % Count % Callees~%")
(do-vertices (node call-graph)
- (print-separator)
- ;;
- ;; Print caller information.
- (dolist (caller (node-callers node))
- (let ((call (find-call caller node)))
- (print-info 4 (node-index caller)
+ (print-separator)
+ ;;
+ ;; Print caller information.
+ (dolist (caller (node-callers node))
+ (let ((call (find-call caller node)))
+ (print-info 4 (node-index caller)
- ;; Print the node itself.
- (format t "~&~6d ~5,1f ~6d ~5,1f ~s [~d]~%"
- (node-count node)
- (samples-percent call-graph (node-count node))
- (node-accrued-count node)
- (samples-percent call-graph (node-accrued-count node))
- (node-name node)
- (node-index node))
- ;; Print callees.
- (do-edges (call called node)
- (print-info 4 (node-index called)
+ ;; Print the node itself.
+ (format t "~&~6d ~5,1f ~6d ~5,1f ~s [~d]~%"
+ (node-count node)
+ (samples-percent call-graph (node-count node))
+ (node-accrued-count node)
+ (samples-percent call-graph (node-accrued-count node))
+ (node-name node)
+ (node-index node))
+ ;; Print callees.
+ (do-edges (call called node)
+ (print-info 4 (node-index called)
- (+ (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))))
+ (+ (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))))