contrib/sb-sprof/test.lisp

   1 (cl:defpackage #:sb-sprof-test
   2   (:use #:cl #:sb-sprof)
   3   (:export #:run-tests))
   4
   5 (cl:in-package #:sb-sprof-test)
   6
   7 ;#+sb-fasteval (setq sb-ext:*evaluator-mode* :compile)
   8
   9 ;;; silly examples
  10
  11 (defun test-0 (n &optional (depth 0))
  12   (declare (optimize (debug 3)))
  13   (when (< depth n)
  14     (dotimes (i n)
  15       (test-0 n (1+ depth))
  16       (test-0 n (1+ depth)))))
  17
  18 (defun test ()
  19   (with-profiling (:reset t :max-samples 1000 :report :graph)
  20     (test-0 7)))
  21
  22 (defun consalot ()
  23   (let ((junk '()))
  24     (loop repeat 10000 do
  25          (push (make-array 10) junk))
  26     junk))
  27
  28 (defun consing-test ()
  29   ;; 0.0001 chosen so that it breaks rather reliably when sprof does not
  30   ;; respect pseudo atomic.
  31   (with-profiling (:reset t
  32                           ;; setitimer with small intervals
  33                           ;; is broken on FreeBSD 10.0
  34                           ;; And ARM targets are not fast in
  35                           ;; general, causing the profiling signal
  36                           ;; to be constantly delivered without
  37                           ;; making any progress.
  38                           #-(or freebsd arm) :sample-interval
  39                           #-(or freebsd arm) 0.0001
  40                           #+arm :sample-interval #+arm 0.1
  41                           :report :graph :loop nil)
  42     (let ((target (+ (get-universal-time) 15)))
  43       (princ #\.)
  44       (force-output)
  45       (loop while (< (get-universal-time) target)
  46          do (consalot)))))
  47
  48 (defun run-tests ()
  49   (test)
  50   (consing-test))
  51
  52 ;; For debugging purposes, print output for visual inspection to see if
  53 ;; the allocation sequence gets hit in the right places (i.e. not at all
  54 ;; in traditional builds, and everywhere if SB-SAFEPOINT-STRICTLY is
  55 ;; enabled.)
  56 #+nil (disassemble #'consalot)