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 (defmacro raises-timeout-p (&body body)
  17   `(handler-case (progn (progn ,@body) nil)
  18     (sb-ext:timeout () t)))
  19
  20 (with-test (:name (:timer :relative)
  21             :fails-on '(and :sparc :linux))
  22   (let* ((has-run-p nil)
  23          (timer (make-timer (lambda () (setq has-run-p t))
  24                             :name "simple timer")))
  25     (schedule-timer timer 0.5)
  26     (sleep 0.2)
  27     (assert (not has-run-p))
  28     (sleep 0.5)
  29     (assert has-run-p)
  30     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
  31
  32 (with-test (:name (:timer :absolute)
  33             :fails-on '(and :sparc :linux))
  34   (let* ((has-run-p nil)
  35          (timer (make-timer (lambda () (setq has-run-p t))
  36                             :name "simple timer")))
  37     (schedule-timer timer (+ 1/2 (get-universal-time)) :absolute-p t)
  38     (sleep 0.2)
  39     (assert (not has-run-p))
  40     (sleep 0.5)
  41     (assert has-run-p)
  42     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
  43
  44 #+sb-thread
  45 (with-test (:name (:timer :other-thread))
  46   (let* ((thread (sb-thread:make-thread (lambda () (sleep 2))))
  47          (timer (make-timer (lambda ()
  48                               (assert (eq thread sb-thread:*current-thread*)))
  49                             :thread thread)))
  50     (schedule-timer timer 0.1)))
  51
  52 #+sb-thread
  53 (with-test (:name (:timer :new-thread))
  54   (let* ((original-thread sb-thread:*current-thread*)
  55          (timer (make-timer
  56                  (lambda ()
  57                    (assert (not (eq original-thread
  58                                     sb-thread:*current-thread*))))
  59                  :thread t)))
  60     (schedule-timer timer 0.1)))
  61
  62 (with-test (:name (:timer :repeat-and-unschedule)
  63             :fails-on '(and :sparc :linux))
  64   (let* ((run-count 0)
  65          timer)
  66     (setq timer
  67           (make-timer (lambda ()
  68                         (when (= 5 (incf run-count))
  69                           (unschedule-timer timer)))))
  70     (schedule-timer timer 0 :repeat-interval 0.2)
  71     (assert (timer-scheduled-p timer :delta 0.3))
  72     (sleep 1.3)
  73     (assert (= 5 run-count))
  74     (assert (not (timer-scheduled-p timer)))
  75     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
  76
  77 (with-test (:name (:timer :reschedule))
  78   (let* ((has-run-p nil)
  79          (timer (make-timer (lambda ()
  80                               (setq has-run-p t)))))
  81     (schedule-timer timer 0.2)
  82     (schedule-timer timer 0.3)
  83     (sleep 0.5)
  84     (assert has-run-p)
  85     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
  86
  87 (with-test (:name (:timer :stress))
  88   (let ((time (1+ (get-universal-time))))
  89     (loop repeat 200 do
  90           (schedule-timer (make-timer (lambda ())) time :absolute-p t))
  91     (sleep 2)
  92     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
  93
  94 (with-test (:name (:with-timeout :timeout))
  95   (assert (raises-timeout-p
  96            (sb-ext:with-timeout 0.2
  97              (sleep 1)))))
  98
  99 (with-test (:name (:with-timeout :fall-through))
 100   (assert (not (raises-timeout-p
 101                 (sb-ext:with-timeout 0.3
 102                   (sleep 0.1))))))
 103
 104 (with-test (:name (:with-timeout :nested-timeout-smaller))
 105   (assert(raises-timeout-p
 106           (sb-ext:with-timeout 10
 107             (sb-ext:with-timeout 0.5
 108               (sleep 2))))))
 109
 110 (with-test (:name (:with-timeout :nested-timeout-bigger))
 111   (assert(raises-timeout-p
 112           (sb-ext:with-timeout 0.5
 113             (sb-ext:with-timeout 2
 114               (sleep 2))))))
 115
 116 (defun wait-for-threads (threads)
 117   (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
 118
 119 #+sb-thread
 120 (with-test (:name (:with-timeout :many-at-the-same-time))
 121   (let ((ok t))
 122     (let ((threads (loop repeat 10 collect
 123                          (sb-thread:make-thread
 124                           (lambda ()
 125                             (handler-case
 126                                 (sb-ext:with-timeout 0.5
 127                                   (sleep 5)
 128                                   (setf ok nil)
 129                                   (format t "~%not ok~%"))
 130                               (timeout ()
 131                                 )))))))
 132       (assert (not (raises-timeout-p
 133                     (sb-ext:with-timeout 20
 134                       (wait-for-threads threads)))))
 135       (assert ok))))
 136
 137 #+sb-thread
 138 (with-test (:name (:with-timeout :dead-thread))
 139   (sb-thread:make-thread
 140    (lambda ()
 141      (let ((timer (make-timer (lambda ()))))
 142        (schedule-timer timer 3)
 143        (assert t))))
 144   (sleep 6)
 145   (assert t))
 146
 147
 148 (defun random-type (n)
 149   `(integer ,(random n) ,(+ n (random n))))
 150
 151 ;;; FIXME: Since timeouts do not work on Windows this would loop
 152 ;;; forever.
 153 #-win32
 154 (with-test (:name '(:hash-cache :interrupt))
 155   (let* ((type1 (random-type 500))
 156          (type2 (random-type 500))
 157          (wanted (subtypep type1 type2)))
 158     (dotimes (i 100)
 159       (block foo
 160         (sb-ext:schedule-timer (sb-ext:make-timer
 161                                 (lambda ()
 162                                   (assert (eq wanted (subtypep type1 type2)))
 163                                     (return-from foo)))
 164                                0.05)
 165         (loop
 166            (assert (eq wanted (subtypep type1 type2))))))))