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