X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-sprof%2Fsb-sprof.lisp;h=31e9d7bc53e35fa451f078bcd2bba2eeaa9a9ffc;hb=6cb4f9ea3f4e35a5a8e75922833e14575ae92180;hp=0fc7423a188c424bc413db0a125c271253888c98;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git

diff --git a/contrib/sb-sprof/sb-sprof.lisp b/contrib/sb-sprof/sb-sprof.lisp
index 0fc7423..31e9d7b 100644
--- a/contrib/sb-sprof/sb-sprof.lisp
+++ b/contrib/sb-sprof/sb-sprof.lisp
@@ -574,9 +574,10 @@
 #+(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
@@ -604,25 +605,26 @@
                                      (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.
@@ -645,9 +647,8 @@
          (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)
@@ -774,7 +775,7 @@
       ;; (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))
@@ -785,7 +786,9 @@
     (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))
@@ -815,6 +818,10 @@
             (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))))
@@ -885,7 +892,9 @@
       (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)))
@@ -893,7 +902,7 @@
                          (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)))))))
 
@@ -1001,7 +1010,9 @@
   (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))