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