0.9.8.33:

[sbcl.git] / contrib / sb-sprof / sb-sprof.lisp

diff --git a/contrib/sb-sprof/sb-sprof.lisp b/contrib/sb-sprof/sb-sprof.lisp
index 5d6a32b..df8fe7d 100644 (file)
--- 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,8 +647,6 @@
          (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)
@@ -775,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))
@@ -786,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))
@@ -1002,7 +1004,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))