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* ((thread (make-kill-thread (lambda () (sleep 2))))
 120          (timer (make-timer (lambda ()
 121                               (assert (eq thread sb-thread:*current-thread*)))
 122                             :thread thread)))
 123     (schedule-timer timer 0.1)))
 124
 125 (with-test (:name (:timer :new-thread) :skipped-on '(not :sb-thread))
 126   (let* ((original-thread sb-thread:*current-thread*)
 127          (timer (make-timer
 128                  (lambda ()
 129                    (assert (not (eq original-thread
 130                                     sb-thread:*current-thread*))))
 131                  :thread t)))
 132     (schedule-timer timer 0.1)))
 133
 134 (with-test (:name (:timer :repeat-and-unschedule)
 135             :fails-on '(and :sparc :linux)
 136             :skipped-on :win32)
 137   (let* ((run-count 0)
 138          timer)
 139     (setq timer
 140           (make-timer (lambda ()
 141                         (when (= 5 (incf run-count))
 142                           (unschedule-timer timer)))))
 143     (schedule-timer timer 0 :repeat-interval 0.2)
 144     (assert (timer-scheduled-p timer :delta 0.3))
 145     (sleep 1.3)
 146     (assert (= 5 run-count))
 147     (assert (not (timer-scheduled-p timer)))
 148     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
 149
 150 (with-test (:name (:timer :reschedule) :skipped-on :win32)
 151   (let* ((has-run-p nil)
 152          (timer (make-timer (lambda ()
 153                               (setq has-run-p t)))))
 154     (schedule-timer timer 0.2)
 155     (schedule-timer timer 0.3)
 156     (sleep 0.5)
 157     (assert has-run-p)
 158     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
 159
 160 (with-test (:name (:timer :stress) :skipped-on :win32)
 161   (let ((time (1+ (get-universal-time))))
 162     (loop repeat 200 do
 163              (schedule-timer (make-timer (lambda ())) time :absolute-p t))
 164     (sleep 2)
 165     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
 166
 167 (with-test (:name (:timer :stress2) :skipped-on :win32)
 168   (let ((time (1+ (get-universal-time)))
 169         (n 0))
 170     (loop for time-n from time upto (+ 1/10 time) by (/ 1/10 200)
 171           do (schedule-timer (make-timer (lambda ())) time-n :absolute-p t)
 172              (incf n))
 173     (sleep 2)
 174     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
 175
 176 (with-test (:name (:with-timeout :timeout) :skipped-on :win32)
 177   (assert (raises-timeout-p
 178            (sb-ext:with-timeout 0.2
 179              (sleep 1)))))
 180
 181 (with-test (:name (:with-timeout :fall-through) :skipped-on :win32)
 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 (defun wait-for-threads (threads)
 199   (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
 200
 201 (with-test (:name (:with-timeout :many-at-the-same-time)
 202                   :skipped-on '(not :sb-thread))
 203   (let ((ok t))
 204     (let ((threads (loop repeat 10 collect
 205                          (sb-thread:make-thread
 206                           (lambda ()
 207                             (handler-case
 208                                 (sb-ext:with-timeout 0.5
 209                                   (sleep 5)
 210                                   (setf ok nil)
 211                                   (format t "~%not ok~%"))
 212                               (timeout ()
 213                                 )))))))
 214       (assert (not (raises-timeout-p
 215                     (sb-ext:with-timeout 20
 216                       (wait-for-threads threads)))))
 217       (assert ok))))
 218
 219 (with-test (:name (:with-timeout :dead-thread) :skipped-on '(not :sb-thread))
 220   (make-join-thread
 221    (lambda ()
 222      (let ((timer (make-timer (lambda ()))))
 223        (schedule-timer timer 3)
 224        (assert t))))
 225   (sleep 6)
 226   (assert t))
 227
 228
 229 (defun random-type (n)
 230   `(integer ,(random n) ,(+ n (random n))))
 231
 232 ;;; FIXME: Since timeouts do not work on Windows this would loop
 233 ;;; forever.
 234 (with-test (:name (:hash-cache :interrupt) :skipped-on :win32)
 235   (let* ((type1 (random-type 500))
 236          (type2 (random-type 500))
 237          (wanted (subtypep type1 type2)))
 238     (dotimes (i 100)
 239       (block foo
 240         (sb-ext:schedule-timer (sb-ext:make-timer
 241                                 (lambda ()
 242                                   (assert (eq wanted (subtypep type1 type2)))
 243                                     (return-from foo)))
 244                                0.05)
 245         (loop
 246            (assert (eq wanted (subtypep type1 type2))))))))
 247
 248 ;;; Used to hang occasionally at least on x86. Two bugs caused it:
 249 ;;; running out of stack (due to repeating timers being rescheduled
 250 ;;; before they ran) and dying threads were open interrupts.
 251 (with-test (:name (:timer :parallel-unschedule)
 252             :skipped-on '(not :sb-thread)
 253             :broken-on ':ppc)
 254   (let ((timer (sb-ext:make-timer (lambda () 42) :name "parallel schedulers"))
 255         (other nil))
 256     (flet ((flop ()
 257              (sleep (random 0.01))
 258              (loop repeat 10000
 259                    do (sb-ext:unschedule-timer timer))))
 260       (sb-sys:with-deadline (:seconds 30)
 261         (loop repeat 5
 262               do (mapcar #'sb-thread:join-thread
 263                            (loop for i from 1 upto 10
 264                                  collect (let* ((thread (sb-thread:make-thread #'flop
 265                                                                                :name (format nil "scheduler ~A" i)))
 266                                                 (ticker (make-limited-timer (lambda () 13)
 267                                                                             1000
 268                                                                             :thread (or other thread)
 269                                                                             :name (format nil "ticker ~A" i))))
 270                                            (setf other thread)
 271                                            (sb-ext:schedule-timer ticker 0 :repeat-interval 0.00001)
 272                                            thread))))))))
 273
 274 ;;;; FIXME: OS X 10.4 doesn't like these being at all, and gives us a SIGSEGV
 275 ;;;; instead of using the Mach expection system! 10.5 on the other tends to
 276 ;;;; lose() here with interrupt already pending. :/
 277 ;;;;
 278 ;;;; Used to have problems in genereal, see comment on (:TIMER
 279 ;;;; :PARALLEL-UNSCHEDULE).
 280 (with-test (:name (:timer :schedule-stress) :skipped-on :win32)
 281   (flet ((test ()
 282          (let* ((slow-timers
 283                  (loop for i from 1 upto 1
 284                        collect (make-limited-timer
 285                                 (lambda () 13)
 286                                 1000
 287                                 :name (format nil "slow ~A" i))))
 288                 (fast-timer (make-limited-timer (lambda () 42) 1000
 289                                                 :name "fast")))
 290            (sb-ext:schedule-timer fast-timer 0.0001 :repeat-interval 0.0001)
 291            (dolist (timer slow-timers)
 292              (sb-ext:schedule-timer timer (random 0.1)
 293                                     :repeat-interval (random 0.1)))
 294            (dolist (timer slow-timers)
 295              (sb-ext:unschedule-timer timer))
 296            (sb-ext:unschedule-timer fast-timer))))
 297   #+sb-thread
 298   (mapcar #'sb-thread:join-thread
 299           (loop repeat 10 collect (sb-thread:make-thread #'test)))
 300   #-sb-thread
 301   (loop repeat 10 do (test))))
 302
 303 (with-test (:name (:timer :threaded-stress)
 304                   :skipped-on '(not :sb-thread)
 305                   :fails-on :win32)
 306   #+win32
 307   (error "fixme")
 308   (let ((barrier (sb-thread:make-semaphore))
 309         (goal 100))
 310     (flet ((wait-for-goal ()
 311              (let ((*n* 0))
 312                (declare (special *n*))
 313                (sb-thread:signal-semaphore barrier)
 314                (loop until (eql *n* goal))))
 315            (one ()
 316              (declare (special *n*))
 317              (incf *n*)))
 318       (let ((threads (list (sb-thread:make-thread #'wait-for-goal)
 319                            (sb-thread:make-thread #'wait-for-goal)
 320                            (sb-thread:make-thread #'wait-for-goal))))
 321         (sb-thread:wait-on-semaphore barrier)
 322         (sb-thread:wait-on-semaphore barrier)
 323         (sb-thread:wait-on-semaphore barrier)
 324         (flet ((sched (thread)
 325                  (sb-thread:make-thread (lambda ()
 326                                           (loop repeat goal
 327                                                 do (sb-ext:schedule-timer (make-timer #'one :thread thread) 0.001))))))
 328           (dolist (thread threads)
 329             (sched thread)))
 330         (mapcar #'sb-thread:join-thread threads)))))
 331
 332 ;; SB-THREAD:MAKE-THREAD used to lock SB-THREAD:*MAKE-THREAD-LOCK*
 333 ;; before entering WITHOUT-INTERRUPTS. When a thread which was
 334 ;; executing SB-THREAD:MAKE-THREAD was interrupted with code which
 335 ;; also called SB-THREAD:MAKE-THREAD, it could happen that the first
 336 ;; thread already owned SB-THREAD:*MAKE-THREAD-LOCK* and the
 337 ;; interrupting code thus made a recursive lock attempt. A timer with
 338 ;; :THREAD T or :THREAD <some thread spawning child threads> could
 339 ;; also trigger this problem.
 340 ;;
 341 ;; See (MAKE-THREAD :INTERRUPT-WITH MAKE-THREAD :BUG-1180102) in
 342 ;; threads.pure.lisp.
 343 (with-test (:name (:timer :dispatch-thread :make-thread :bug-1180102)
 344             :skipped-on '(not :sb-thread))
 345   (flet ((test (thread)
 346            (let ((timer (make-timer (lambda ()) :thread thread)))
 347              (schedule-timer timer .01 :repeat-interval 0.1)
 348              (dotimes (i 100)
 349                (let ((threads '()))
 350                  (dotimes (i 100)
 351                    (push (sb-thread:make-thread (lambda () (sleep .01)))
 352                          threads))
 353                  (mapc #'sb-thread:join-thread threads)))
 354              (unschedule-timer timer))))
 355     (test t)
 356     (test sb-thread:*current-thread*)))
 357
 358 ;; A timer with a repeat interval can be configured to "catch up" in
 359 ;; case of missed calls.
 360 (with-test (:name (:timer :catch-up))
 361   (flet ((test (&rest args)
 362            (let ((timer (make-timer (lambda ()))))
 363              (apply #'schedule-timer timer .01 args)
 364              (unschedule-timer timer))))
 365     ;; :CATCH-UP does not make sense without :REPEAT-INTERVAL.
 366     (assert-error (test :catch-up nil))
 367     (assert-error (test :catch-up t))
 368     ;; These combinations are allowed.
 369     (test :repeat-interval .01 :catch-up nil)
 370     (test :repeat-interval .01 :catch-up t)))