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 (sb-alien:define-alien-routine "check_deferrables_blocked_or_lose"
  17     void)
  18 (sb-alien:define-alien-routine "check_deferrables_unblocked_or_lose"
  19     void)
  20
  21 (defun make-limited-timer (fn n &rest args)
  22   (let (timer)
  23     (setq timer
  24           (apply #'sb-ext:make-timer
  25                  (lambda ()
  26                    (sb-sys:without-interrupts
  27                      (decf n)
  28                      (cond ((minusp n)
  29                             (warn "Unscheduling timer ~A ~
  30                                    upon reaching run limit. System too slow?"
  31                                   timer)
  32                             (sb-ext:unschedule-timer timer))
  33                            (t
  34                             (sb-sys:allow-with-interrupts
  35                               (funcall fn))))))
  36                  args))))
  37
  38 (defun make-and-schedule-and-wait (fn time)
  39   (let ((finishedp nil))
  40     (sb-ext:schedule-timer (sb-ext:make-timer
  41                             (lambda ()
  42                               (sb-sys:without-interrupts
  43                                 (unwind-protect
  44                                      (sb-sys:allow-with-interrupts
  45                                        (funcall fn))
  46                                   (setq finishedp t)))))
  47                            time)
  48     (loop until finishedp)))
  49
  50 (with-test (:name (:timer :deferrables-blocked))
  51   (make-and-schedule-and-wait (lambda ()
  52                                 (check-deferrables-blocked-or-lose))
  53                               (random 0.1))
  54   (check-deferrables-unblocked-or-lose))
  55
  56 (with-test (:name (:timer :deferrables-unblocked))
  57   (make-and-schedule-and-wait (lambda ()
  58                                 (sb-sys:with-interrupts
  59                                   (check-deferrables-unblocked-or-lose)))
  60                               (random 0.1))
  61   (check-deferrables-unblocked-or-lose))
  62
  63 #-win32
  64 (with-test (:name (:timer :deferrables-unblocked :unwind))
  65   (catch 'xxx
  66     (make-and-schedule-and-wait (lambda ()
  67                                   (check-deferrables-blocked-or-lose)
  68                                   (throw 'xxx nil))
  69                                 (random 0.1))
  70     (sleep 1))
  71   (check-deferrables-unblocked-or-lose))
  72
  73 (defmacro raises-timeout-p (&body body)
  74   `(handler-case (progn (progn ,@body) nil)
  75     (sb-ext:timeout () t)))
  76
  77 (with-test (:name (:timer :relative)
  78             :fails-on '(and :sparc :linux))
  79   (let* ((has-run-p nil)
  80          (timer (make-timer (lambda () (setq has-run-p t))
  81                             :name "simple timer")))
  82     (schedule-timer timer 0.5)
  83     (sleep 0.2)
  84     (assert (not has-run-p))
  85     (sleep 0.5)
  86     (assert has-run-p)
  87     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
  88
  89 (with-test (:name (:timer :absolute)
  90             :fails-on '(and :sparc :linux))
  91   (let* ((has-run-p nil)
  92          (timer (make-timer (lambda () (setq has-run-p t))
  93                             :name "simple timer")))
  94     (schedule-timer timer (+ 1/2 (get-universal-time)) :absolute-p t)
  95     (sleep 0.2)
  96     (assert (not has-run-p))
  97     (sleep 0.5)
  98     (assert has-run-p)
  99     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
 100
 101 #+sb-thread
 102 (with-test (:name (:timer :other-thread))
 103   (let* ((thread (sb-thread:make-thread (lambda () (sleep 2))))
 104          (timer (make-timer (lambda ()
 105                               (assert (eq thread sb-thread:*current-thread*)))
 106                             :thread thread)))
 107     (schedule-timer timer 0.1)))
 108
 109 #+sb-thread
 110 (with-test (:name (:timer :new-thread))
 111   (let* ((original-thread sb-thread:*current-thread*)
 112          (timer (make-timer
 113                  (lambda ()
 114                    (assert (not (eq original-thread
 115                                     sb-thread:*current-thread*))))
 116                  :thread t)))
 117     (schedule-timer timer 0.1)))
 118
 119 (with-test (:name (:timer :repeat-and-unschedule)
 120             :fails-on '(and :sparc :linux))
 121   (let* ((run-count 0)
 122          timer)
 123     (setq timer
 124           (make-timer (lambda ()
 125                         (when (= 5 (incf run-count))
 126                           (unschedule-timer timer)))))
 127     (schedule-timer timer 0 :repeat-interval 0.2)
 128     (assert (timer-scheduled-p timer :delta 0.3))
 129     (sleep 1.3)
 130     (assert (= 5 run-count))
 131     (assert (not (timer-scheduled-p timer)))
 132     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
 133
 134 (with-test (:name (:timer :reschedule))
 135   (let* ((has-run-p nil)
 136          (timer (make-timer (lambda ()
 137                               (setq has-run-p t)))))
 138     (schedule-timer timer 0.2)
 139     (schedule-timer timer 0.3)
 140     (sleep 0.5)
 141     (assert has-run-p)
 142     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
 143
 144 (with-test (:name (:timer :stress))
 145   (let ((time (1+ (get-universal-time))))
 146     (loop repeat 200 do
 147           (schedule-timer (make-timer (lambda ())) time :absolute-p t))
 148     (sleep 2)
 149     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
 150
 151 (with-test (:name (:with-timeout :timeout))
 152   (assert (raises-timeout-p
 153            (sb-ext:with-timeout 0.2
 154              (sleep 1)))))
 155
 156 (with-test (:name (:with-timeout :fall-through))
 157   (assert (not (raises-timeout-p
 158                 (sb-ext:with-timeout 0.3
 159                   (sleep 0.1))))))
 160
 161 (with-test (:name (:with-timeout :nested-timeout-smaller))
 162   (assert(raises-timeout-p
 163           (sb-ext:with-timeout 10
 164             (sb-ext:with-timeout 0.5
 165               (sleep 2))))))
 166
 167 (with-test (:name (:with-timeout :nested-timeout-bigger))
 168   (assert(raises-timeout-p
 169           (sb-ext:with-timeout 0.5
 170             (sb-ext:with-timeout 2
 171               (sleep 2))))))
 172
 173 (defun wait-for-threads (threads)
 174   (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
 175
 176 #+sb-thread
 177 (with-test (:name (:with-timeout :many-at-the-same-time))
 178   (let ((ok t))
 179     (let ((threads (loop repeat 10 collect
 180                          (sb-thread:make-thread
 181                           (lambda ()
 182                             (handler-case
 183                                 (sb-ext:with-timeout 0.5
 184                                   (sleep 5)
 185                                   (setf ok nil)
 186                                   (format t "~%not ok~%"))
 187                               (timeout ()
 188                                 )))))))
 189       (assert (not (raises-timeout-p
 190                     (sb-ext:with-timeout 20
 191                       (wait-for-threads threads)))))
 192       (assert ok))))
 193
 194 #+sb-thread
 195 (with-test (:name (:with-timeout :dead-thread))
 196   (sb-thread:make-thread
 197    (lambda ()
 198      (let ((timer (make-timer (lambda ()))))
 199        (schedule-timer timer 3)
 200        (assert t))))
 201   (sleep 6)
 202   (assert t))
 203
 204
 205 (defun random-type (n)
 206   `(integer ,(random n) ,(+ n (random n))))
 207
 208 ;;; FIXME: Since timeouts do not work on Windows this would loop
 209 ;;; forever.
 210 #-win32
 211 (with-test (:name (:hash-cache :interrupt))
 212   (let* ((type1 (random-type 500))
 213          (type2 (random-type 500))
 214          (wanted (subtypep type1 type2)))
 215     (dotimes (i 100)
 216       (block foo
 217         (sb-ext:schedule-timer (sb-ext:make-timer
 218                                 (lambda ()
 219                                   (assert (eq wanted (subtypep type1 type2)))
 220                                     (return-from foo)))
 221                                0.05)
 222         (loop
 223            (assert (eq wanted (subtypep type1 type2))))))))
 224
 225 ;;; Used to hang occasionally at least on x86. Two bugs caused it:
 226 ;;; running out of stack (due to repeating timers being rescheduled
 227 ;;; before they ran) and dying threads were open interrupts.
 228 #+sb-thread
 229 (with-test (:name (:timer :parallel-unschedule))
 230   (let ((timer (sb-ext:make-timer (lambda () 42) :name "parallel schedulers"))
 231         (other nil))
 232     (flet ((flop ()
 233              (sleep (random 0.01))
 234              (loop repeat 10000
 235                    do (sb-ext:unschedule-timer timer))))
 236       (loop repeat 5
 237             do (mapcar #'sb-thread:join-thread
 238                        (loop for i from 1 upto 10
 239                              collect (let* ((thread (sb-thread:make-thread #'flop
 240                                                                            :name (format nil "scheduler ~A" i)))
 241                                             (ticker (make-limited-timer (lambda () 13)
 242                                                                                1000
 243                                                                                :thread (or other thread)
 244                                                                                :name (format nil "ticker ~A" i))))
 245                                        (setf other thread)
 246                                        (sb-ext:schedule-timer ticker 0 :repeat-interval 0.00001)
 247                                        thread)))))))
 248
 249 ;;;; FIXME: OS X 10.4 doesn't like these being at all, and gives us a SIGSEGV
 250 ;;;; instead of using the Mach expection system! 10.5 on the other tends to
 251 ;;;; lose() here with interrupt already pending. :/
 252 ;;;;
 253 ;;;; Used to have problems in genereal, see comment on (:TIMER
 254 ;;;; :PARALLEL-UNSCHEDULE).
 255 (with-test (:name (:timer :schedule-stress))
 256   (flet ((test ()
 257          (let* ((slow-timers
 258                  (loop for i from 1 upto 1
 259                        collect (make-limited-timer
 260                                 (lambda () 13)
 261                                 1000
 262                                 :name (format nil "slow ~A" i))))
 263                 (fast-timer (make-limited-timer (lambda () 42) 1000
 264                                                 :name "fast")))
 265            (sb-ext:schedule-timer fast-timer 0.0001 :repeat-interval 0.0001)
 266            (dolist (timer slow-timers)
 267              (sb-ext:schedule-timer timer (random 0.1)
 268                                     :repeat-interval (random 0.1)))
 269            (dolist (timer slow-timers)
 270              (sb-ext:unschedule-timer timer))
 271            (sb-ext:unschedule-timer fast-timer))))
 272   #+sb-thread
 273   (mapcar #'sb-thread:join-thread
 274           (loop repeat 10 collect (sb-thread:make-thread #'test)))
 275   #-sb-thread
 276   (loop repeat 10 do (test))))
 277
 278 #+sb-thread
 279 (with-test (:name (:timer :threaded-stress))
 280   (let ((barrier (sb-thread:make-semaphore))
 281         (goal 100))
 282     (flet ((wait-for-goal ()
 283              (let ((*n* 0))
 284                (declare (special *n*))
 285                (sb-thread:signal-semaphore barrier)
 286                (loop until (eql *n* goal))))
 287            (one ()
 288              (declare (special *n*))
 289              (incf *n*)))
 290       (let ((threads (list (sb-thread:make-thread #'wait-for-goal)
 291                            (sb-thread:make-thread #'wait-for-goal)
 292                            (sb-thread:make-thread #'wait-for-goal))))
 293         (sb-thread:wait-on-semaphore barrier)
 294         (sb-thread:wait-on-semaphore barrier)
 295         (sb-thread:wait-on-semaphore barrier)
 296         (flet ((sched (thread)
 297                  (sb-thread:make-thread (lambda ()
 298                                           (loop repeat goal
 299                                                 do (sb-ext:schedule-timer (make-timer #'one :thread thread) 0.001))))))
 300           (dolist (thread threads)
 301             (sched thread)))
 302         (mapcar #'sb-thread:join-thread threads)))))