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 (sb-alien:define-alien-routine "check_deferrables_blocked_or_lose"
18 (where sb-alien:unsigned-long))
19 (sb-alien:define-alien-routine "check_deferrables_unblocked_or_lose"
21 (where sb-alien:unsigned-long))
23 (defun make-limited-timer (fn n &rest args)
26 (apply #'sb-ext:make-timer
28 (sb-sys:without-interrupts
31 (warn "Unscheduling timer ~A ~
32 upon reaching run limit. System too slow?"
34 (sb-ext:unschedule-timer timer))
36 (sb-sys:allow-with-interrupts
40 (defun make-and-schedule-and-wait (fn time)
41 (let ((finishedp nil))
42 (sb-ext:schedule-timer (sb-ext:make-timer
44 (sb-sys:without-interrupts
46 (sb-sys:allow-with-interrupts
48 (setq finishedp t)))))
50 (loop until finishedp)))
52 (with-test (:name (:timer :deferrables-blocked))
53 (make-and-schedule-and-wait (lambda ()
54 (check-deferrables-blocked-or-lose 0))
56 (check-deferrables-unblocked-or-lose 0))
58 (with-test (:name (:timer :deferrables-unblocked))
59 (make-and-schedule-and-wait (lambda ()
60 (sb-sys:with-interrupts
61 (check-deferrables-unblocked-or-lose 0)))
63 (check-deferrables-unblocked-or-lose 0))
66 (with-test (:name (:timer :deferrables-unblocked :unwind))
68 (make-and-schedule-and-wait (lambda ()
69 (check-deferrables-blocked-or-lose 0)
73 (check-deferrables-unblocked-or-lose 0))
75 (defmacro raises-timeout-p (&body body)
76 `(handler-case (progn (progn ,@body) nil)
77 (sb-ext:timeout () t)))
79 (with-test (:name (:timer :relative)
80 :fails-on '(and :sparc :linux))
81 (let* ((has-run-p nil)
82 (timer (make-timer (lambda () (setq has-run-p t))
83 :name "simple timer")))
84 (schedule-timer timer 0.5)
86 (assert (not has-run-p))
89 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
91 (with-test (:name (:timer :absolute)
92 :fails-on '(and :sparc :linux))
93 (let* ((has-run-p nil)
94 (timer (make-timer (lambda () (setq has-run-p t))
95 :name "simple timer")))
96 (schedule-timer timer (+ 1/2 (get-universal-time)) :absolute-p t)
98 (assert (not has-run-p))
101 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
104 (with-test (:name (:timer :other-thread))
105 (let* ((thread (sb-thread:make-thread (lambda () (sleep 2))))
106 (timer (make-timer (lambda ()
107 (assert (eq thread sb-thread:*current-thread*)))
109 (schedule-timer timer 0.1)))
112 (with-test (:name (:timer :new-thread))
113 (let* ((original-thread sb-thread:*current-thread*)
116 (assert (not (eq original-thread
117 sb-thread:*current-thread*))))
119 (schedule-timer timer 0.1)))
121 (with-test (:name (:timer :repeat-and-unschedule)
122 :fails-on '(and :sparc :linux))
126 (make-timer (lambda ()
127 (when (= 5 (incf run-count))
128 (unschedule-timer timer)))))
129 (schedule-timer timer 0 :repeat-interval 0.2)
130 (assert (timer-scheduled-p timer :delta 0.3))
132 (assert (= 5 run-count))
133 (assert (not (timer-scheduled-p timer)))
134 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
136 (with-test (:name (:timer :reschedule))
137 (let* ((has-run-p nil)
138 (timer (make-timer (lambda ()
139 (setq has-run-p t)))))
140 (schedule-timer timer 0.2)
141 (schedule-timer timer 0.3)
144 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
146 (with-test (:name (:timer :stress))
147 (let ((time (1+ (get-universal-time))))
149 (schedule-timer (make-timer (lambda ())) time :absolute-p t))
151 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
153 (with-test (:name (:with-timeout :timeout))
154 (assert (raises-timeout-p
155 (sb-ext:with-timeout 0.2
158 (with-test (:name (:with-timeout :fall-through))
159 (assert (not (raises-timeout-p
160 (sb-ext:with-timeout 0.3
163 (with-test (:name (:with-timeout :nested-timeout-smaller))
164 (assert(raises-timeout-p
165 (sb-ext:with-timeout 10
166 (sb-ext:with-timeout 0.5
169 (with-test (:name (:with-timeout :nested-timeout-bigger))
170 (assert(raises-timeout-p
171 (sb-ext:with-timeout 0.5
172 (sb-ext:with-timeout 2
175 (defun wait-for-threads (threads)
176 (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
179 (with-test (:name (:with-timeout :many-at-the-same-time))
181 (let ((threads (loop repeat 10 collect
182 (sb-thread:make-thread
185 (sb-ext:with-timeout 0.5
188 (format t "~%not ok~%"))
191 (assert (not (raises-timeout-p
192 (sb-ext:with-timeout 20
193 (wait-for-threads threads)))))
197 (with-test (:name (:with-timeout :dead-thread))
198 (sb-thread:make-thread
200 (let ((timer (make-timer (lambda ()))))
201 (schedule-timer timer 3)
207 (defun random-type (n)
208 `(integer ,(random n) ,(+ n (random n))))
210 ;;; FIXME: Since timeouts do not work on Windows this would loop
213 (with-test (:name (:hash-cache :interrupt))
214 (let* ((type1 (random-type 500))
215 (type2 (random-type 500))
216 (wanted (subtypep type1 type2)))
219 (sb-ext:schedule-timer (sb-ext:make-timer
221 (assert (eq wanted (subtypep type1 type2)))
225 (assert (eq wanted (subtypep type1 type2))))))))
227 ;;; Used to hang occasionally at least on x86. Two bugs caused it:
228 ;;; running out of stack (due to repeating timers being rescheduled
229 ;;; before they ran) and dying threads were open interrupts.
231 (with-test (:name (:timer :parallel-unschedule))
232 (let ((timer (sb-ext:make-timer (lambda () 42) :name "parallel schedulers"))
235 (sleep (random 0.01))
237 do (sb-ext:unschedule-timer timer))))
239 do (mapcar #'sb-thread:join-thread
240 (loop for i from 1 upto 10
241 collect (let* ((thread (sb-thread:make-thread #'flop
242 :name (format nil "scheduler ~A" i)))
243 (ticker (make-limited-timer (lambda () 13)
245 :thread (or other thread)
246 :name (format nil "ticker ~A" i))))
248 (sb-ext:schedule-timer ticker 0 :repeat-interval 0.00001)
251 ;;;; FIXME: OS X 10.4 doesn't like these being at all, and gives us a SIGSEGV
252 ;;;; instead of using the Mach expection system! 10.5 on the other tends to
253 ;;;; lose() here with interrupt already pending. :/
255 ;;;; Used to have problems in genereal, see comment on (:TIMER
256 ;;;; :PARALLEL-UNSCHEDULE).
257 (with-test (:name (:timer :schedule-stress))
260 (loop for i from 1 upto 1
261 collect (make-limited-timer
264 :name (format nil "slow ~A" i))))
265 (fast-timer (make-limited-timer (lambda () 42) 1000
267 (sb-ext:schedule-timer fast-timer 0.0001 :repeat-interval 0.0001)
268 (dolist (timer slow-timers)
269 (sb-ext:schedule-timer timer (random 0.1)
270 :repeat-interval (random 0.1)))
271 (dolist (timer slow-timers)
272 (sb-ext:unschedule-timer timer))
273 (sb-ext:unschedule-timer fast-timer))))
275 (mapcar #'sb-thread:join-thread
276 (loop repeat 10 collect (sb-thread:make-thread #'test)))
278 (loop repeat 10 do (test))))
281 (with-test (:name (:timer :threaded-stress))
282 (let ((barrier (sb-thread:make-semaphore))
284 (flet ((wait-for-goal ()
286 (declare (special *n*))
287 (sb-thread:signal-semaphore barrier)
288 (loop until (eql *n* goal))))
290 (declare (special *n*))
292 (let ((threads (list (sb-thread:make-thread #'wait-for-goal)
293 (sb-thread:make-thread #'wait-for-goal)
294 (sb-thread:make-thread #'wait-for-goal))))
295 (sb-thread:wait-on-semaphore barrier)
296 (sb-thread:wait-on-semaphore barrier)
297 (sb-thread:wait-on-semaphore barrier)
298 (flet ((sched (thread)
299 (sb-thread:make-thread (lambda ()
301 do (sb-ext:schedule-timer (make-timer #'one :thread thread) 0.001))))))
302 (dolist (thread threads)
304 (mapcar #'sb-thread:join-thread threads)))))