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 #-win32
  65 (with-test (:name (:timer :deferrables-blocked))
  66   (make-and-schedule-and-wait (lambda ()
  67                                 (check-deferrables-blocked-or-lose 0))
  68                               (random 0.1))
  69   (check-deferrables-unblocked-or-lose 0))
  70
  71 #-win32
  72 (with-test (:name (:timer :deferrables-unblocked))
  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 #-win32
  80 (with-test (:name (:timer :deferrables-unblocked :unwind))
  81   (catch 'xxx
  82     (make-and-schedule-and-wait (lambda ()
  83                                   (check-deferrables-blocked-or-lose 0)
  84                                   (throw 'xxx nil))
  85                                 (random 0.1))
  86     (sleep 1))
  87   (check-deferrables-unblocked-or-lose 0))
  88
  89 (defmacro raises-timeout-p (&body body)
  90   `(handler-case (progn (progn ,@body) nil)
  91     (sb-ext:timeout () t)))
  92
  93 #-win32
  94 (with-test (:name (:timer :relative)
  95             :fails-on '(and :sparc :linux))
  96   (let* ((has-run-p nil)
  97          (timer (make-timer (lambda () (setq has-run-p t))
  98                             :name "simple timer")))
  99     (schedule-timer timer 0.5)
 100     (sleep 0.2)
 101     (assert (not has-run-p))
 102     (sleep 0.5)
 103     (assert has-run-p)
 104     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
 105
 106 #-win32
 107 (with-test (:name (:timer :absolute)
 108             :fails-on '(and :sparc :linux))
 109   (let* ((has-run-p nil)
 110          (timer (make-timer (lambda () (setq has-run-p t))
 111                             :name "simple timer")))
 112     (schedule-timer timer (+ 1/2 (get-universal-time)) :absolute-p t)
 113     (sleep 0.2)
 114     (assert (not has-run-p))
 115     (sleep 0.5)
 116     (assert has-run-p)
 117     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
 118
 119 #+sb-thread
 120 (with-test (:name (:timer :other-thread))
 121   (let* ((thread (sb-thread:make-thread (lambda () (sleep 2))))
 122          (timer (make-timer (lambda ()
 123                               (assert (eq thread sb-thread:*current-thread*)))
 124                             :thread thread)))
 125     (schedule-timer timer 0.1)))
 126
 127 #+sb-thread
 128 (with-test (:name (:timer :new-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 #-win32
 138 (with-test (:name (:timer :repeat-and-unschedule)
 139             :fails-on '(and :sparc :linux))
 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 #-win32
 154 (with-test (:name (:timer :reschedule))
 155   (let* ((has-run-p nil)
 156          (timer (make-timer (lambda ()
 157                               (setq has-run-p t)))))
 158     (schedule-timer timer 0.2)
 159     (schedule-timer timer 0.3)
 160     (sleep 0.5)
 161     (assert has-run-p)
 162     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
 163
 164 #-win32
 165 (with-test (:name (:timer :stress))
 166   (let ((time (1+ (get-universal-time))))
 167     (loop repeat 200 do
 168              (schedule-timer (make-timer (lambda ())) time :absolute-p t))
 169     (sleep 2)
 170     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
 171
 172 #-win32
 173 (with-test (:name (:timer :stress2))
 174   (let ((time (1+ (get-universal-time)))
 175         (n 0))
 176     (loop for time-n from time upto (+ 1/10 time) by (/ 1/10 200)
 177           do (schedule-timer (make-timer (lambda ())) time-n :absolute-p t)
 178              (incf n))
 179     (sleep 2)
 180     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
 181
 182 #-win32
 183 (with-test (:name (:with-timeout :timeout))
 184   (assert (raises-timeout-p
 185            (sb-ext:with-timeout 0.2
 186              (sleep 1)))))
 187
 188 #-win32
 189 (with-test (:name (:with-timeout :fall-through))
 190   (assert (not (raises-timeout-p
 191                 (sb-ext:with-timeout 0.3
 192                   (sleep 0.1))))))
 193
 194 #-win32
 195 (with-test (:name (:with-timeout :nested-timeout-smaller))
 196   (assert(raises-timeout-p
 197           (sb-ext:with-timeout 10
 198             (sb-ext:with-timeout 0.5
 199               (sleep 2))))))
 200
 201 #-win32
 202 (with-test (:name (:with-timeout :nested-timeout-bigger))
 203   (assert(raises-timeout-p
 204           (sb-ext:with-timeout 0.5
 205             (sb-ext:with-timeout 2
 206               (sleep 2))))))
 207
 208 (defun wait-for-threads (threads)
 209   (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
 210
 211 #+sb-thread
 212 (with-test (:name (:with-timeout :many-at-the-same-time))
 213   (let ((ok t))
 214     (let ((threads (loop repeat 10 collect
 215                          (sb-thread:make-thread
 216                           (lambda ()
 217                             (handler-case
 218                                 (sb-ext:with-timeout 0.5
 219                                   (sleep 5)
 220                                   (setf ok nil)
 221                                   (format t "~%not ok~%"))
 222                               (timeout ()
 223                                 )))))))
 224       (assert (not (raises-timeout-p
 225                     (sb-ext:with-timeout 20
 226                       (wait-for-threads threads)))))
 227       (assert ok))))
 228
 229 #+sb-thread
 230 (with-test (:name (:with-timeout :dead-thread))
 231   (sb-thread:make-thread
 232    (lambda ()
 233      (let ((timer (make-timer (lambda ()))))
 234        (schedule-timer timer 3)
 235        (assert t))))
 236   (sleep 6)
 237   (assert t))
 238
 239
 240 (defun random-type (n)
 241   `(integer ,(random n) ,(+ n (random n))))
 242
 243 ;;; FIXME: Since timeouts do not work on Windows this would loop
 244 ;;; forever.
 245 #-win32
 246 (with-test (:name (:hash-cache :interrupt))
 247   (let* ((type1 (random-type 500))
 248          (type2 (random-type 500))
 249          (wanted (subtypep type1 type2)))
 250     (dotimes (i 100)
 251       (block foo
 252         (sb-ext:schedule-timer (sb-ext:make-timer
 253                                 (lambda ()
 254                                   (assert (eq wanted (subtypep type1 type2)))
 255                                     (return-from foo)))
 256                                0.05)
 257         (loop
 258            (assert (eq wanted (subtypep type1 type2))))))))
 259
 260 ;;; Used to hang occasionally at least on x86. Two bugs caused it:
 261 ;;; running out of stack (due to repeating timers being rescheduled
 262 ;;; before they ran) and dying threads were open interrupts.
 263 #+sb-thread
 264 (with-test (:name (:timer :parallel-unschedule) :fails-on :ppc)
 265   #+darwin
 266   (error "Prone to hang on Darwin due to interrupt issues.")
 267   #+ppc
 268   (error "Prone to hang the host on linux/ppc for unknown reasons.")
 269   (let ((timer (sb-ext:make-timer (lambda () 42) :name "parallel schedulers"))
 270         (other nil))
 271     (flet ((flop ()
 272              (sleep (random 0.01))
 273              (loop repeat 10000
 274                    do (sb-ext:unschedule-timer timer))))
 275       (loop repeat 5
 276             do (mapcar #'sb-thread:join-thread
 277                        (loop for i from 1 upto 10
 278                              collect (let* ((thread (sb-thread:make-thread #'flop
 279                                                                            :name (format nil "scheduler ~A" i)))
 280                                             (ticker (make-limited-timer (lambda () 13)
 281                                                                                1000
 282                                                                                :thread (or other thread)
 283                                                                                :name (format nil "ticker ~A" i))))
 284                                        (setf other thread)
 285                                        (sb-ext:schedule-timer ticker 0 :repeat-interval 0.00001)
 286                                        thread)))))))
 287
 288 ;;;; FIXME: OS X 10.4 doesn't like these being at all, and gives us a SIGSEGV
 289 ;;;; instead of using the Mach expection system! 10.5 on the other tends to
 290 ;;;; lose() here with interrupt already pending. :/
 291 ;;;;
 292 ;;;; Used to have problems in genereal, see comment on (:TIMER
 293 ;;;; :PARALLEL-UNSCHEDULE).
 294 #-win32
 295 (with-test (:name (:timer :schedule-stress))
 296   (flet ((test ()
 297          (let* ((slow-timers
 298                  (loop for i from 1 upto 1
 299                        collect (make-limited-timer
 300                                 (lambda () 13)
 301                                 1000
 302                                 :name (format nil "slow ~A" i))))
 303                 (fast-timer (make-limited-timer (lambda () 42) 1000
 304                                                 :name "fast")))
 305            (sb-ext:schedule-timer fast-timer 0.0001 :repeat-interval 0.0001)
 306            (dolist (timer slow-timers)
 307              (sb-ext:schedule-timer timer (random 0.1)
 308                                     :repeat-interval (random 0.1)))
 309            (dolist (timer slow-timers)
 310              (sb-ext:unschedule-timer timer))
 311            (sb-ext:unschedule-timer fast-timer))))
 312   #+sb-thread
 313   (mapcar #'sb-thread:join-thread
 314           (loop repeat 10 collect (sb-thread:make-thread #'test)))
 315   #-sb-thread
 316   (loop repeat 10 do (test))))
 317
 318 #+sb-thread
 319 (with-test (:name (:timer :threaded-stress))
 320   (let ((barrier (sb-thread:make-semaphore))
 321         (goal 100))
 322     (flet ((wait-for-goal ()
 323              (let ((*n* 0))
 324                (declare (special *n*))
 325                (sb-thread:signal-semaphore barrier)
 326                (loop until (eql *n* goal))))
 327            (one ()
 328              (declare (special *n*))
 329              (incf *n*)))
 330       (let ((threads (list (sb-thread:make-thread #'wait-for-goal)
 331                            (sb-thread:make-thread #'wait-for-goal)
 332                            (sb-thread:make-thread #'wait-for-goal))))
 333         (sb-thread:wait-on-semaphore barrier)
 334         (sb-thread:wait-on-semaphore barrier)
 335         (sb-thread:wait-on-semaphore barrier)
 336         (flet ((sched (thread)
 337                  (sb-thread:make-thread (lambda ()
 338                                           (loop repeat goal
 339                                                 do (sb-ext:schedule-timer (make-timer #'one :thread thread) 0.001))))))
 340           (dolist (thread threads)
 341             (sched thread)))
 342         (mapcar #'sb-thread:join-thread threads)))))