#+(or x86 x86-64)
(defun sigprof-handler (signal code scp)
(declare (ignore signal code) (type system-area-pointer scp))
- (when (and *sampling*
- (< *samples-index* (length *samples*)))
- (sb-sys:without-gcing
+ (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
(sap-int ra)
0)))
(t
- (record 0)))))))))))
+ (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))
- (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.
(end (+ start (sb-kernel:%code-code-size code))))
(values start end)))
-;;; Record the addresses of dynamic-space code objects in
-;;; *DYNAMIC-SPACE-CODE-INFO*. Call this with GC disabled.
(defun record-dyninfo ()
+ (setf *dynamic-space-code-info* nil)
(flet ((record-address (code size)
(declare (ignore size))
(multiple-value-bind (start end)
;; (pushnew 'turn-off-sampling *before-gc-hooks*)
(pushnew 'adjust-samples-for-address-changes *after-gc-hooks*)
(record-dyninfo)
- (sb-sys:enable-interrupt sb-unix::sigprof #'sigprof-handler)
+ (sb-sys:enable-interrupt sb-unix:sigprof #'sigprof-handler)
(unix-setitimer :profile secs usecs secs usecs)
(setq *profiling* t)))
(values))
(setq *after-gc-hooks*
(delete 'adjust-samples-for-address-changes *after-gc-hooks*))
(unix-setitimer :profile 0 0 0 0)
- (sb-sys:enable-interrupt sb-unix::sigprof :default)
+ ;; Even with the timer shut down we cannot be sure that there is
+ ;; no undelivered sigprof. Besides, leaving the signal handler
+ ;; installed won't hurt.
(setq *sampling* nil)
(setq *profiling* nil))
(values))
(end-offset (sb-c::compiled-debug-fun-elsewhere-pc cdf))
(component (sb-di::compiled-debug-fun-component info))
(start-pc (code-start component)))
+ ;; Call graphs are mostly useless unless we somehow
+ ;; distinguish a gazillion different (LAMBDA ())'s.
+ (when (equal name '(lambda ()))
+ (setf name (format nil "Unknown component: #x~x" start-pc)))
(%make-node :name name
:start-pc (+ start-pc start-offset)
:end-pc (+ start-pc end-offset))))
(let ((info (debug-info pc)))
(when info
(let* ((new (make-node info))
- (found (gethash (node-name new) *name->node*)))
+ (key (cons (node-name new)
+ (node-start-pc new)))
+ (found (gethash key *name->node*)))
(cond (found
(setf (node-start-pc found)
(min (node-start-pc found) (node-start-pc new)))
(max (node-end-pc found) (node-end-pc new)))
found)
(t
- (setf (gethash (node-name new) *name->node*) new)
+ (setf (gethash key *name->node*) new)
(tree-insert new)
new)))))))
(format t "~&~V,,,V<~>~%" length char))
(defun samples-percent (call-graph count)
- (* 100.0 (/ count (call-graph-nsamples call-graph))))
+ (if (> count 0)
+ (* 100.0 (/ count (call-graph-nsamples call-graph)))
+ 0))
(defun print-call-graph-header (call-graph)
(let ((nsamples (call-graph-nsamples call-graph))