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 (sb-alien:define-alien-routine "check_deferrables_unblocked_or_lose"
21 (defun make-limited-timer (fn n &rest args)
24 (apply #'sb-ext:make-timer
26 (sb-sys:without-interrupts
29 (warn "Unscheduling timer ~A ~
30 upon reaching run limit. System too slow?"
32 (sb-ext:unschedule-timer timer))
34 (sb-sys:allow-with-interrupts
38 (defun make-and-schedule-and-wait (fn time)
39 (let ((finishedp nil))
40 (sb-ext:schedule-timer (sb-ext:make-timer
42 (sb-sys:without-interrupts
44 (sb-sys:allow-with-interrupts
46 (setq finishedp t)))))
48 (loop until finishedp)))
50 (with-test (:name (:timer :deferrables-blocked))
51 (make-and-schedule-and-wait (lambda ()
52 (check-deferrables-blocked-or-lose))
54 (check-deferrables-unblocked-or-lose))
56 (with-test (:name (:timer :deferrables-unblocked))
57 (make-and-schedule-and-wait (lambda ()
58 (sb-sys:with-interrupts
59 (check-deferrables-unblocked-or-lose)))
61 (check-deferrables-unblocked-or-lose))
63 (with-test (:name (:timer :deferrables-unblocked :unwind))
65 (make-and-schedule-and-wait (lambda ()
66 (check-deferrables-blocked-or-lose)
70 (check-deferrables-unblocked-or-lose))
72 (defmacro raises-timeout-p (&body body)
73 `(handler-case (progn (progn ,@body) nil)
74 (sb-ext:timeout () t)))
76 (with-test (:name (:timer :relative)
77 :fails-on '(and :sparc :linux))
78 (let* ((has-run-p nil)
79 (timer (make-timer (lambda () (setq has-run-p t))
80 :name "simple timer")))
81 (schedule-timer timer 0.5)
83 (assert (not has-run-p))
86 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
88 (with-test (:name (:timer :absolute)
89 :fails-on '(and :sparc :linux))
90 (let* ((has-run-p nil)
91 (timer (make-timer (lambda () (setq has-run-p t))
92 :name "simple timer")))
93 (schedule-timer timer (+ 1/2 (get-universal-time)) :absolute-p t)
95 (assert (not has-run-p))
98 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
101 (with-test (:name (:timer :other-thread))
102 (let* ((thread (sb-thread:make-thread (lambda () (sleep 2))))
103 (timer (make-timer (lambda ()
104 (assert (eq thread sb-thread:*current-thread*)))
106 (schedule-timer timer 0.1)))
109 (with-test (:name (:timer :new-thread))
110 (let* ((original-thread sb-thread:*current-thread*)
113 (assert (not (eq original-thread
114 sb-thread:*current-thread*))))
116 (schedule-timer timer 0.1)))
118 (with-test (:name (:timer :repeat-and-unschedule)
119 :fails-on '(and :sparc :linux))
123 (make-timer (lambda ()
124 (when (= 5 (incf run-count))
125 (unschedule-timer timer)))))
126 (schedule-timer timer 0 :repeat-interval 0.2)
127 (assert (timer-scheduled-p timer :delta 0.3))
129 (assert (= 5 run-count))
130 (assert (not (timer-scheduled-p timer)))
131 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
133 (with-test (:name (:timer :reschedule))
134 (let* ((has-run-p nil)
135 (timer (make-timer (lambda ()
136 (setq has-run-p t)))))
137 (schedule-timer timer 0.2)
138 (schedule-timer timer 0.3)
141 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
143 (with-test (:name (:timer :stress))
144 (let ((time (1+ (get-universal-time))))
146 (schedule-timer (make-timer (lambda ())) time :absolute-p t))
148 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
150 (with-test (:name (:with-timeout :timeout))
151 (assert (raises-timeout-p
152 (sb-ext:with-timeout 0.2
155 (with-test (:name (:with-timeout :fall-through))
156 (assert (not (raises-timeout-p
157 (sb-ext:with-timeout 0.3
160 (with-test (:name (:with-timeout :nested-timeout-smaller))
161 (assert(raises-timeout-p
162 (sb-ext:with-timeout 10
163 (sb-ext:with-timeout 0.5
166 (with-test (:name (:with-timeout :nested-timeout-bigger))
167 (assert(raises-timeout-p
168 (sb-ext:with-timeout 0.5
169 (sb-ext:with-timeout 2
172 (defun wait-for-threads (threads)
173 (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
176 (with-test (:name (:with-timeout :many-at-the-same-time))
178 (let ((threads (loop repeat 10 collect
179 (sb-thread:make-thread
182 (sb-ext:with-timeout 0.5
185 (format t "~%not ok~%"))
188 (assert (not (raises-timeout-p
189 (sb-ext:with-timeout 20
190 (wait-for-threads threads)))))
194 (with-test (:name (:with-timeout :dead-thread))
195 (sb-thread:make-thread
197 (let ((timer (make-timer (lambda ()))))
198 (schedule-timer timer 3)
204 (defun random-type (n)
205 `(integer ,(random n) ,(+ n (random n))))
207 ;;; FIXME: Since timeouts do not work on Windows this would loop
210 (with-test (:name (:hash-cache :interrupt))
211 (let* ((type1 (random-type 500))
212 (type2 (random-type 500))
213 (wanted (subtypep type1 type2)))
216 (sb-ext:schedule-timer (sb-ext:make-timer
218 (assert (eq wanted (subtypep type1 type2)))
222 (assert (eq wanted (subtypep type1 type2))))))))
224 ;;; Used to hang occasionally at least on x86. Two bugs caused it:
225 ;;; running out of stack (due to repeating timers being rescheduled
226 ;;; before they ran) and dying threads were open interrupts.
228 (with-test (:name (:timer :parallel-unschedule))
229 (let ((timer (sb-ext:make-timer (lambda () 42) :name "parallel schedulers"))
232 (sleep (random 0.01))
234 do (sb-ext:unschedule-timer timer))))
236 do (mapcar #'sb-thread:join-thread
237 (loop for i from 1 upto 10
238 collect (let* ((thread (sb-thread:make-thread #'flop
239 :name (format nil "scheduler ~A" i)))
240 (ticker (make-limited-timer (lambda () 13)
242 :thread (or other thread)
243 :name (format nil "ticker ~A" i))))
245 (sb-ext:schedule-timer ticker 0 :repeat-interval 0.00001)
248 ;;;; FIXME: OS X 10.4 doesn't like these being at all, and gives us a SIGSEGV
249 ;;;; instead of using the Mach expection system! 10.5 on the other tends to
250 ;;;; lose() here with interrupt already pending. :/
252 ;;;; Used to have problems in genereal, see comment on (:TIMER
253 ;;;; :PARALLEL-UNSCHEDULE).
254 (with-test (:name (:timer :schedule-stress))
257 (loop for i from 1 upto 1
258 collect (make-limited-timer
261 :name (format nil "slow ~A" i))))
262 (fast-timer (make-limited-timer (lambda () 42) 1000
264 (sb-ext:schedule-timer fast-timer 0.0001 :repeat-interval 0.0001)
265 (dolist (timer slow-timers)
266 (sb-ext:schedule-timer timer (random 0.1)
267 :repeat-interval (random 0.1)))
268 (dolist (timer slow-timers)
269 (sb-ext:unschedule-timer timer))
270 (sb-ext:unschedule-timer fast-timer))))
272 (mapcar #'sb-thread:join-thread
273 (loop repeat 10 collect (sb-thread:make-thread #'test)))
275 (loop repeat 10 do (test))))
278 (with-test (:name (:timer :threaded-stress))
279 (let ((barrier (sb-thread:make-semaphore))
281 (flet ((wait-for-goal ()
283 (declare (special *n*))
284 (sb-thread:signal-semaphore barrier)
285 (loop until (eql *n* goal))))
287 (declare (special *n*))
289 (let ((threads (list (sb-thread:make-thread #'wait-for-goal)
290 (sb-thread:make-thread #'wait-for-goal)
291 (sb-thread:make-thread #'wait-for-goal))))
292 (sb-thread:wait-on-semaphore barrier)
293 (sb-thread:wait-on-semaphore barrier)
294 (sb-thread:wait-on-semaphore barrier)
295 (flet ((sched (thread)
296 (sb-thread:make-thread (lambda ()
298 do (sb-ext:schedule-timer (make-timer #'one :thread thread) 0.001))))))
299 (dolist (thread threads)
301 (mapcar #'sb-thread:join-thread threads)))))