make SB-SPROF:WITH-PROFILING not loop by default

[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 ab1edf2..a9f6f05 100644 (file)
--- a/contrib/sb-sprof/sb-sprof.lisp
+++ b/contrib/sb-sprof/sb-sprof.lisp
@@ -354,7 +354,7 @@ on the depth of the call stack.")
 
 (defvar *sampling-mode* :cpu
   "Default sampling mode. :CPU for cpu profiling, :ALLOC for allocation
-profiling")
+profiling, and :TIME for wallclock profilgin.")
 (declaim (type (member :cpu :alloc :time) *sampling-mode*))
 
 (defvar *alloc-region-size*
@@ -507,14 +507,16 @@ profiling")
   (defvar *profiler-lock* (sb-thread:make-mutex :name "Statistical Profiler"))
   (defvar *distribution-lock* (sb-thread:make-mutex :name "Wallclock profiling lock"))
 
+  #+sb-thread
   (declaim (inline pthread-kill))
+  #+sb-thread
   (define-alien-routine pthread-kill int (os-thread unsigned-long) (signal int))
 
   ;;; A random thread will call this in response to either a timer firing,
   ;;; This in turn will distribute the notice to those threads we are
   ;;; interested using SIGPROF.
   (defun thread-distribution-handler ()
-    (declare (optimize sb-c::merge-tail-calls))
+    (declare (optimize speed (space 0)))
     (when *sampling*
       #+sb-thread
       (let ((lock *distribution-lock*))
@@ -641,7 +643,7 @@ profiling")
                                 (max-samples '*max-samples*)
                                 (reset nil)
                                 (mode '*sampling-mode*)
-                                (loop t)
+                                (loop nil)
                                 (max-depth most-positive-fixnum)
                                 show-progress
                                 (threads '(list sb-thread:*current-thread*))
@@ -698,6 +700,7 @@ profiling")
      If true (the default) repeatedly evaluate BODY. If false, evaluate
      if only once."
   (declare (type report-type report))
+  (check-type loop boolean)
   `(let* ((*sample-interval* ,sample-interval)
           (*alloc-interval* ,alloc-interval)
           (*sampling* nil)
@@ -707,21 +710,22 @@ profiling")
      (unwind-protect
           (progn
             (start-profiling :max-depth ,max-depth :threads ,threads)
-            (loop
-               (when (>= (samples-trace-count *samples*)
-                         (samples-max-samples *samples*))
-                 (return))
-               ,@(when show-progress
-                       `((format t "~&===> ~d of ~d samples taken.~%"
-                                 (samples-trace-count *samples*)
-                                 (samples-max-samples *samples*))))
-               (let ((.last-index. (samples-index *samples*)))
-                 ,@body
-                 (when (= .last-index. (samples-index *samples*))
-                   (warn "No sampling progress; possibly a profiler bug.")
-                   (return)))
-               (unless ,loop
-                 (return))))
+            ,(if loop
+                 `(loop
+                     (when (>= (samples-trace-count *samples*)
+                               (samples-max-samples *samples*))
+                       (return))
+                     ,@(when show-progress
+                             `((format t "~&===> ~d of ~d samples taken.~%"
+                                       (samples-trace-count *samples*)
+                                       (samples-max-samples *samples*))))
+                     (let ((.last-index. (samples-index *samples*)))
+                       ,@body
+                       (when (= .last-index. (samples-index *samples*))
+                         (warn "No sampling progress; possibly a profiler bug.")
+                         (return))))
+                `(progn
+                   ,@body)))
        (stop-profiling))
      ,@(when report-p `((report :type ,report)))))
 
@@ -792,7 +796,9 @@ The following keyword args are recognized:
                                     :mode mode))
       (enable-call-counting)
       (setf *profiled-threads* threads)
-      (sb-sys:enable-interrupt sb-unix:sigprof #'sigprof-handler)
+      (sb-sys:enable-interrupt sb-unix:sigprof
+                               #'sigprof-handler
+                               :synchronous t)
       (ecase mode
         (:alloc
          (let ((alloc-signal (1- alloc-interval)))
@@ -865,9 +871,7 @@ The following keyword args are recognized:
            (if (and (consp name)
                     (member (first name)
                             '(sb-c::xep sb-c::tl-xep sb-c::&more-processor
-                              sb-c::varargs-entry
                               sb-c::top-level-form
-                              sb-c::hairy-arg-processor
                               sb-c::&optional-processor)))
                (second name)
                name)))
@@ -1407,6 +1411,23 @@ functions during statistical profiling."
   (with-profiling (:reset t :max-samples 1000 :report :graph)
     (test-0 7)))
 
+(defun consalot ()
+  (let ((junk '()))
+    (loop repeat 10000 do
+         (push (make-array 10) junk))
+    junk))
+
+(defun consing-test ()
+  ;; 0.0001 chosen so that it breaks rather reliably when sprof does not
+  ;; respect pseudo atomic.
+  (with-profiling (:reset t :sample-interval 0.0001 :report :graph :loop nil)
+    (let ((target (+ (get-universal-time) 15)))
+      (princ #\.)
+      (force-output)
+      (loop
+         while (< (get-universal-time) target)
+         do (consalot)))))
+
 
 ;;; provision
 (provide 'sb-sprof)