1 ;;;; This software is part of the SBCL system. See the README file for
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
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.
12 (in-package "CL-USER")
14 (use-package :test-util)
16 (defmacro raises-timeout-p (&body body)
17 `(handler-case (progn (progn ,@body) nil)
18 (sb-ext:timeout () t)))
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)
27 (assert (not has-run-p))
30 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
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)
39 (assert (not has-run-p))
42 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
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*)))
50 (schedule-timer timer 0.1)))
53 (with-test (:name (:timer :new-thread))
54 (let* ((original-thread sb-thread:*current-thread*)
57 (assert (not (eq original-thread
58 sb-thread:*current-thread*))))
60 (schedule-timer timer 0.1)))
62 (with-test (:name (:timer :repeat-and-unschedule)
63 :fails-on '(and :sparc :linux))
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))
73 (assert (= 5 run-count))
74 (assert (not (timer-scheduled-p timer)))
75 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
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)
85 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
87 (with-test (:name (:timer :stress))
88 (let ((time (1+ (get-universal-time))))
90 (schedule-timer (make-timer (lambda ())) time :absolute-p t))
92 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
94 (with-test (:name (:with-timeout :timeout))
95 (assert (raises-timeout-p
96 (sb-ext:with-timeout 0.2
99 (with-test (:name (:with-timeout :fall-through))
100 (assert (not (raises-timeout-p
101 (sb-ext:with-timeout 0.3
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
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
116 (defun wait-for-threads (threads)
117 (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
120 (with-test (:name (:with-timeout :many-at-the-same-time))
122 (let ((threads (loop repeat 10 collect
123 (sb-thread:make-thread
126 (sb-ext:with-timeout 0.5
129 (format t "~%not ok~%"))
132 (assert (not (raises-timeout-p
133 (sb-ext:with-timeout 20
134 (wait-for-threads threads)))))
138 (with-test (:name (:with-timeout :dead-thread))
139 (sb-thread:make-thread
141 (let ((timer (make-timer (lambda ()))))
142 (schedule-timer timer 3)
148 (defun random-type (n)
149 `(integer ,(random n) ,(+ n (random n))))
151 ;;; FIXME: Since timeouts do not work on Windows this would loop
154 (with-test (:name (:hash-cache :interrupt))
155 (let* ((type1 (random-type 500))
156 (type2 (random-type 500))
157 (wanted (subtypep type1 type2)))
160 (sb-ext:schedule-timer (sb-ext:make-timer
162 (assert (eq wanted (subtypep type1 type2)))
166 (assert (eq wanted (subtypep type1 type2))))))))
169 (with-test (:name (:timer :parallel-unschedule))
170 (let ((timer (sb-ext:make-timer (lambda () 42) :name "parallel schedulers"))
173 (sleep (random 0.01))
175 do (sb-ext:unschedule-timer timer))))
177 do (mapcar #'sb-thread:join-thread
178 (loop for i from 1 upto 10
179 collect (let* ((thread (sb-thread:make-thread #'flop
180 :name (format nil "scheduler ~A" i)))
181 (ticker (sb-ext:make-timer (lambda () 13) :thread (or other thread)
182 :name (format nil "ticker ~A" i))))
184 (sb-ext:schedule-timer ticker 0 :repeat-interval 0.00001)
187 ;;;; FIXME: OS X 10.4 doesn't like these being at all, and gives us a SIGSEGV
188 ;;;; instead of using the Mach expection system! 10.5 on the other tends to
189 ;;;; lose() where with interrupt already pending. :/
191 ;;;; FIXME: This test also occasionally hangs on Linux/x86-64 at least. The
192 ;;;; common feature is one thread in gc_stop_the_world, and another trying to
193 ;;;; signal_interrupt_thread, but both (apparently) getting EAGAIN repeatedly.
194 ;;;; Exactly how or why this is happening remains under investigation -- but
195 ;;;; it seems plausible that the fast timers simply fill up the interrupt
196 ;;;; queue completely. (On some occasions the process unwedges itself after
197 ;;;; a few minutes, but not always.)
199 ;;;; FIXME: Another failure mode on Linux: recursive entries to
200 ;;;; RUN-EXPIRED-TIMERS blowing the stack.
202 (with-test (:name (:timer :schedule-stress))
204 (let* ((slow-timers (loop for i from 1 upto 100
205 collect (sb-ext:make-timer (lambda () 13) :name (format nil "slow ~A" i))))
206 (fast-timer (sb-ext:make-timer (lambda () 42) :name "fast")))
207 (sb-ext:schedule-timer fast-timer 0.0001 :repeat-interval 0.0001)
208 (dolist (timer slow-timers)
209 (sb-ext:schedule-timer timer (random 0.1) :repeat-interval (random 0.1)))
210 (dolist (timer slow-timers)
211 (sb-ext:unschedule-timer timer))
212 (sb-ext:unschedule-timer fast-timer))))
214 (mapcar #'sb-thread:join-thread (loop repeat 10 collect (sb-thread:make-thread #'test)))
216 (loop repeat 10 do (test))))
219 (with-test (:name (:timer :threaded-stress))
220 (let ((barrier (sb-thread:make-semaphore))
222 (flet ((wait-for-goal ()
224 (declare (special *n*))
225 (sb-thread:signal-semaphore barrier)
226 (loop until (eql *n* goal))))
228 (declare (special *n*))
230 (let ((threads (list (sb-thread:make-thread #'wait-for-goal)
231 (sb-thread:make-thread #'wait-for-goal)
232 (sb-thread:make-thread #'wait-for-goal))))
233 (sb-thread:wait-on-semaphore barrier)
234 (sb-thread:wait-on-semaphore barrier)
235 (sb-thread:wait-on-semaphore barrier)
236 (flet ((sched (thread)
237 (sb-thread:make-thread (lambda ()
239 do (sb-ext:schedule-timer (make-timer #'one :thread thread) 0.001))))))
240 (dolist (thread threads)
242 (mapcar #'sb-thread:join-thread threads)))))