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