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