X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-sprof%2Ftest.lisp;h=43432ef652c79a2f2183cb2a466b1f11534ebdae;hb=04b902c7279d7f9e5fa75bccca2e26a002544eca;hp=9a1696031b825a94f47f097fdf954c5a9117201e;hpb=f8664e5b8a5dfdcc6d0cb2f923b7de7a4322a1fa;p=sbcl.git

diff --git a/contrib/sb-sprof/test.lisp b/contrib/sb-sprof/test.lisp
index 9a16960..43432ef 100644
--- a/contrib/sb-sprof/test.lisp
+++ b/contrib/sb-sprof/test.lisp
@@ -1,13 +1,44 @@
 (in-package :cl-user)
+
 (require :sb-sprof)
 
+;;; silly examples
+
+(defun test-0 (n &optional (depth 0))
+  (declare (optimize (debug 3)))
+  (when (< depth n)
+    (dotimes (i n)
+      (test-0 n (1+ depth))
+      (test-0 n (1+ depth)))))
+
+(defun test ()
+  (sb-sprof: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.
+  (sb-sprof: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)))))
+
 #-(or win32 darwin)                    ;not yet
-(sb-sprof::test)
+(test)
 #-(or win32 darwin)                    ;not yet
-(sb-sprof::consing-test)
+(consing-test)
 
 ;; For debugging purposes, print output for visual inspection to see if
 ;; the allocation sequence gets hit in the right places (i.e. not at all
 ;; in traditional builds, and everywhere if SB-SAFEPOINT-STRICTLY is
 ;; enabled.)
-(disassemble #'sb-sprof::consalot)
+(disassemble #'consalot)