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