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
)))))