tests/timer.impure.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; While most of SBCL is derived from the CMU CL system, the test
   5 ;;;; files (like this one) were written from scratch after the fork
   6 ;;;; from CMU CL.
   7 ;;;;
   8 ;;;; This software is in the public domain and is provided with
   9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  10 ;;;; more information.
  11
  12 (in-package "CL-USER")
  13
  14 (use-package :test-util)
  15
  16 (defmacro raises-timeout-p (&body body)
  17   `(handler-case (progn (progn ,@body) nil)
  18     (sb-ext:timeout () t)))
  19
  20 (with-test (:name (:timer :relative)
  21             :fails-on '(and :sparc :linux))
  22   (let* ((has-run-p nil)
  23          (timer (make-timer (lambda () (setq has-run-p t))
  24                             :name "simple timer")))
  25     (schedule-timer timer 0.5)
  26     (sleep 0.2)
  27     (assert (not has-run-p))
  28     (sleep 0.5)
  29     (assert has-run-p)
  30     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
  31
  32 (with-test (:name (:timer :absolute)
  33             :fails-on '(and :sparc :linux))
  34   (let* ((has-run-p nil)
  35          (timer (make-timer (lambda () (setq has-run-p t))
  36                             :name "simple timer")))
  37     (schedule-timer timer (+ 1/2 (get-universal-time)) :absolute-p t)
  38     (sleep 0.2)
  39     (assert (not has-run-p))
  40     (sleep 0.5)
  41     (assert has-run-p)
  42     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
  43
  44 #+sb-thread
  45 (with-test (:name (:timer :other-thread))
  46   (let* ((thread (sb-thread:make-thread (lambda () (sleep 2))))
  47          (timer (make-timer (lambda ()
  48                               (assert (eq thread sb-thread:*current-thread*)))
  49                             :thread thread)))
  50     (schedule-timer timer 0.1)))
  51
  52 #+sb-thread
  53 (with-test (:name (:timer :new-thread))
  54   (let* ((original-thread sb-thread:*current-thread*)
  55          (timer (make-timer
  56                  (lambda ()
  57                    (assert (not (eq original-thread
  58                                     sb-thread:*current-thread*))))
  59                  :thread t)))
  60     (schedule-timer timer 0.1)))
  61
  62 (with-test (:name (:timer :repeat-and-unschedule)
  63             :fails-on '(and :sparc :linux))
  64   (let* ((run-count 0)
  65          timer)
  66     (setq timer
  67           (make-timer (lambda ()
  68                         (when (= 5 (incf run-count))
  69                           (unschedule-timer timer)))))
  70     (schedule-timer timer 0 :repeat-interval 0.2)
  71     (assert (timer-scheduled-p timer :delta 0.3))
  72     (sleep 1.3)
  73     (assert (= 5 run-count))
  74     (assert (not (timer-scheduled-p timer)))
  75     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
  76
  77 (with-test (:name (:timer :reschedule))
  78   (let* ((has-run-p nil)
  79          (timer (make-timer (lambda ()
  80                               (setq has-run-p t)))))
  81     (schedule-timer timer 0.2)
  82     (schedule-timer timer 0.3)
  83     (sleep 0.5)
  84     (assert has-run-p)
  85     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
  86
  87 (with-test (:name (:timer :stress))
  88   (let ((time (1+ (get-universal-time))))
  89     (loop repeat 200 do
  90           (schedule-timer (make-timer (lambda ())) time :absolute-p t))
  91     (sleep 2)
  92     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
  93
  94 (with-test (:name (:with-timeout :timeout))
  95   (assert (raises-timeout-p
  96            (sb-ext:with-timeout 0.2
  97              (sleep 1)))))
  98
  99 (with-test (:name (:with-timeout :fall-through))
 100   (assert (not (raises-timeout-p
 101                 (sb-ext:with-timeout 0.3
 102                   (sleep 0.1))))))
 103
 104 (with-test (:name (:with-timeout :nested-timeout-smaller))
 105   (assert(raises-timeout-p
 106           (sb-ext:with-timeout 10
 107             (sb-ext:with-timeout 0.5
 108               (sleep 2))))))
 109
 110 (with-test (:name (:with-timeout :nested-timeout-bigger))
 111   (assert(raises-timeout-p
 112           (sb-ext:with-timeout 0.5
 113             (sb-ext:with-timeout 2
 114               (sleep 2))))))
 115
 116 (defun wait-for-threads (threads)
 117   (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
 118
 119 #+sb-thread
 120 (with-test (:name (:with-timeout :many-at-the-same-time))
 121   (let ((ok t))
 122     (let ((threads (loop repeat 10 collect
 123                          (sb-thread:make-thread
 124                           (lambda ()
 125                             (handler-case
 126                                 (sb-ext:with-timeout 0.5
 127                                   (sleep 5)
 128                                   (setf ok nil)
 129                                   (format t "~%not ok~%"))
 130                               (timeout ()
 131                                 )))))))
 132       (assert (not (raises-timeout-p
 133                     (sb-ext:with-timeout 20
 134                       (wait-for-threads threads)))))
 135       (assert ok))))
 136
 137 #+sb-thread
 138 (with-test (:name (:with-timeout :dead-thread))
 139   (sb-thread:make-thread
 140    (lambda ()
 141      (let ((timer (make-timer (lambda ()))))
 142        (schedule-timer timer 3)
 143        (assert t))))
 144   (sleep 6)
 145   (assert t))
 146
 147
 148 (defun random-type (n)
 149   `(integer ,(random n) ,(+ n (random n))))
 150
 151 ;;; FIXME: Since timeouts do not work on Windows this would loop
 152 ;;; forever.
 153 #-win32
 154 (with-test (:name (:hash-cache :interrupt))
 155   (let* ((type1 (random-type 500))
 156          (type2 (random-type 500))
 157          (wanted (subtypep type1 type2)))
 158     (dotimes (i 100)
 159       (block foo
 160         (sb-ext:schedule-timer (sb-ext:make-timer
 161                                 (lambda ()
 162                                   (assert (eq wanted (subtypep type1 type2)))
 163                                     (return-from foo)))
 164                                0.05)
 165         (loop
 166            (assert (eq wanted (subtypep type1 type2))))))))
 167
 168 ;;; Disabled. Hangs occasionally at least on x86. See comment before
 169 ;;; the next test case.
 170 #+(and nil sb-thread)
 171 (with-test (:name (:timer :parallel-unschedule))
 172   (let ((timer (sb-ext:make-timer (lambda () 42) :name "parallel schedulers"))
 173         (other nil))
 174     (flet ((flop ()
 175              (sleep (random 0.01))
 176              (loop repeat 10000
 177                    do (sb-ext:unschedule-timer timer))))
 178       (loop repeat 5
 179             do (mapcar #'sb-thread:join-thread
 180                        (loop for i from 1 upto 10
 181                              collect (let* ((thread (sb-thread:make-thread #'flop
 182                                                                            :name (format nil "scheduler ~A" i)))
 183                                             (ticker (sb-ext:make-timer (lambda () 13) :thread (or other thread)
 184                                                                        :name (format nil "ticker ~A" i))))
 185                                        (setf other thread)
 186                                        (sb-ext:schedule-timer ticker 0 :repeat-interval 0.00001)
 187                                        thread)))))))
 188
 189 ;;;; FIXME: OS X 10.4 doesn't like these being at all, and gives us a SIGSEGV
 190 ;;;; instead of using the Mach expection system! 10.5 on the other tends to
 191 ;;;; lose() where with interrupt already pending. :/
 192 ;;;;
 193 ;;;; FIXME: This test also occasionally hangs on Linux/x86-64 at least. The
 194 ;;;; common feature is one thread in gc_stop_the_world, and another trying to
 195 ;;;; signal_interrupt_thread, but both (apparently) getting EAGAIN repeatedly.
 196 ;;;; Exactly how or why this is happening remains under investigation -- but
 197 ;;;; it seems plausible that the fast timers simply fill up the interrupt
 198 ;;;; queue completely. (On some occasions the process unwedges itself after
 199 ;;;; a few minutes, but not always.)
 200 ;;;;
 201 ;;;; FIXME: Another failure mode on Linux: recursive entries to
 202 ;;;; RUN-EXPIRED-TIMERS blowing the stack.
 203 #+nil
 204 (with-test (:name (:timer :schedule-stress))
 205   (flet ((test ()
 206            (let* ((slow-timers (loop for i from 1 upto 100
 207                                      collect (sb-ext:make-timer (lambda () 13) :name (format nil "slow ~A" i))))
 208                   (fast-timer (sb-ext:make-timer (lambda () 42) :name "fast")))
 209              (sb-ext:schedule-timer fast-timer 0.0001 :repeat-interval 0.0001)
 210              (dolist (timer slow-timers)
 211                (sb-ext:schedule-timer timer (random 0.1) :repeat-interval (random 0.1)))
 212              (dolist (timer slow-timers)
 213                (sb-ext:unschedule-timer timer))
 214              (sb-ext:unschedule-timer fast-timer))))
 215     #+sb-thread
 216     (mapcar #'sb-thread:join-thread (loop repeat 10 collect (sb-thread:make-thread #'test)))
 217     #-sb-thread
 218     (loop repeat 10 do (test))))
 219
 220 #+sb-thread
 221 (with-test (:name (:timer :threaded-stress))
 222   (let ((barrier (sb-thread:make-semaphore))
 223         (goal 100))
 224     (flet ((wait-for-goal ()
 225              (let ((*n* 0))
 226                (declare (special *n*))
 227                (sb-thread:signal-semaphore barrier)
 228                (loop until (eql *n* goal))))
 229            (one ()
 230              (declare (special *n*))
 231              (incf *n*)))
 232       (let ((threads (list (sb-thread:make-thread #'wait-for-goal)
 233                            (sb-thread:make-thread #'wait-for-goal)
 234                            (sb-thread:make-thread #'wait-for-goal))))
 235         (sb-thread:wait-on-semaphore barrier)
 236         (sb-thread:wait-on-semaphore barrier)
 237         (sb-thread:wait-on-semaphore barrier)
 238         (flet ((sched (thread)
 239                  (sb-thread:make-thread (lambda ()
 240                                           (loop repeat goal
 241                                                 do (sb-ext:schedule-timer (make-timer #'one :thread thread) 0.001))))))
 242           (dolist (thread threads)
 243             (sched thread)))
 244         (mapcar #'sb-thread:join-thread threads)))))