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))
64 (with-test (:name (:timer :deferrables-unblocked :unwind))
66 (make-and-schedule-and-wait (lambda ()
67 (check-deferrables-blocked-or-lose)
71 (check-deferrables-unblocked-or-lose))
73 (defmacro raises-timeout-p (&body body)
74 `(handler-case (progn (progn ,@body) nil)
75 (sb-ext:timeout () t)))
77 (with-test (:name (:timer :relative)
78 :fails-on '(and :sparc :linux))
79 (let* ((has-run-p nil)
80 (timer (make-timer (lambda () (setq has-run-p t))
81 :name "simple timer")))
82 (schedule-timer timer 0.5)
84 (assert (not has-run-p))
87 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
89 (with-test (:name (:timer :absolute)
90 :fails-on '(and :sparc :linux))
91 (let* ((has-run-p nil)
92 (timer (make-timer (lambda () (setq has-run-p t))
93 :name "simple timer")))
94 (schedule-timer timer (+ 1/2 (get-universal-time)) :absolute-p t)
96 (assert (not has-run-p))
99 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
102 (with-test (:name (:timer :other-thread))
103 (let* ((thread (sb-thread:make-thread (lambda () (sleep 2))))
104 (timer (make-timer (lambda ()
105 (assert (eq thread sb-thread:*current-thread*)))
107 (schedule-timer timer 0.1)))
110 (with-test (:name (:timer :new-thread))
111 (let* ((original-thread sb-thread:*current-thread*)
114 (assert (not (eq original-thread
115 sb-thread:*current-thread*))))
117 (schedule-timer timer 0.1)))
119 (with-test (:name (:timer :repeat-and-unschedule)
120 :fails-on '(and :sparc :linux))
124 (make-timer (lambda ()
125 (when (= 5 (incf run-count))
126 (unschedule-timer timer)))))
127 (schedule-timer timer 0 :repeat-interval 0.2)
128 (assert (timer-scheduled-p timer :delta 0.3))
130 (assert (= 5 run-count))
131 (assert (not (timer-scheduled-p timer)))
132 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
134 (with-test (:name (:timer :reschedule))
135 (let* ((has-run-p nil)
136 (timer (make-timer (lambda ()
137 (setq has-run-p t)))))
138 (schedule-timer timer 0.2)
139 (schedule-timer timer 0.3)
142 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
144 (with-test (:name (:timer :stress))
145 (let ((time (1+ (get-universal-time))))
147 (schedule-timer (make-timer (lambda ())) time :absolute-p t))
149 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
151 (with-test (:name (:with-timeout :timeout))
152 (assert (raises-timeout-p
153 (sb-ext:with-timeout 0.2
156 (with-test (:name (:with-timeout :fall-through))
157 (assert (not (raises-timeout-p
158 (sb-ext:with-timeout 0.3
161 (with-test (:name (:with-timeout :nested-timeout-smaller))
162 (assert(raises-timeout-p
163 (sb-ext:with-timeout 10
164 (sb-ext:with-timeout 0.5
167 (with-test (:name (:with-timeout :nested-timeout-bigger))
168 (assert(raises-timeout-p
169 (sb-ext:with-timeout 0.5
170 (sb-ext:with-timeout 2
173 (defun wait-for-threads (threads)
174 (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
177 (with-test (:name (:with-timeout :many-at-the-same-time))
179 (let ((threads (loop repeat 10 collect
180 (sb-thread:make-thread
183 (sb-ext:with-timeout 0.5
186 (format t "~%not ok~%"))
189 (assert (not (raises-timeout-p
190 (sb-ext:with-timeout 20
191 (wait-for-threads threads)))))
195 (with-test (:name (:with-timeout :dead-thread))
196 (sb-thread:make-thread
198 (let ((timer (make-timer (lambda ()))))
199 (schedule-timer timer 3)
205 (defun random-type (n)
206 `(integer ,(random n) ,(+ n (random n))))
208 ;;; FIXME: Since timeouts do not work on Windows this would loop
211 (with-test (:name (:hash-cache :interrupt))
212 (let* ((type1 (random-type 500))
213 (type2 (random-type 500))
214 (wanted (subtypep type1 type2)))
217 (sb-ext:schedule-timer (sb-ext:make-timer
219 (assert (eq wanted (subtypep type1 type2)))
223 (assert (eq wanted (subtypep type1 type2))))))))
225 ;;; Used to hang occasionally at least on x86. Two bugs caused it:
226 ;;; running out of stack (due to repeating timers being rescheduled
227 ;;; before they ran) and dying threads were open interrupts.
229 (with-test (:name (:timer :parallel-unschedule))
230 (let ((timer (sb-ext:make-timer (lambda () 42) :name "parallel schedulers"))
233 (sleep (random 0.01))
235 do (sb-ext:unschedule-timer timer))))
237 do (mapcar #'sb-thread:join-thread
238 (loop for i from 1 upto 10
239 collect (let* ((thread (sb-thread:make-thread #'flop
240 :name (format nil "scheduler ~A" i)))
241 (ticker (make-limited-timer (lambda () 13)
243 :thread (or other thread)
244 :name (format nil "ticker ~A" i))))
246 (sb-ext:schedule-timer ticker 0 :repeat-interval 0.00001)
249 ;;;; FIXME: OS X 10.4 doesn't like these being at all, and gives us a SIGSEGV
250 ;;;; instead of using the Mach expection system! 10.5 on the other tends to
251 ;;;; lose() here with interrupt already pending. :/
253 ;;;; Used to have problems in genereal, see comment on (:TIMER
254 ;;;; :PARALLEL-UNSCHEDULE).
255 (with-test (:name (:timer :schedule-stress))
258 (loop for i from 1 upto 1
259 collect (make-limited-timer
262 :name (format nil "slow ~A" i))))
263 (fast-timer (make-limited-timer (lambda () 42) 1000
265 (sb-ext:schedule-timer fast-timer 0.0001 :repeat-interval 0.0001)
266 (dolist (timer slow-timers)
267 (sb-ext:schedule-timer timer (random 0.1)
268 :repeat-interval (random 0.1)))
269 (dolist (timer slow-timers)
270 (sb-ext:unschedule-timer timer))
271 (sb-ext:unschedule-timer fast-timer))))
273 (mapcar #'sb-thread:join-thread
274 (loop repeat 10 collect (sb-thread:make-thread #'test)))
276 (loop repeat 10 do (test))))
279 (with-test (:name (:timer :threaded-stress))
280 (let ((barrier (sb-thread:make-semaphore))
282 (flet ((wait-for-goal ()
284 (declare (special *n*))
285 (sb-thread:signal-semaphore barrier)
286 (loop until (eql *n* goal))))
288 (declare (special *n*))
290 (let ((threads (list (sb-thread:make-thread #'wait-for-goal)
291 (sb-thread:make-thread #'wait-for-goal)
292 (sb-thread:make-thread #'wait-for-goal))))
293 (sb-thread:wait-on-semaphore barrier)
294 (sb-thread:wait-on-semaphore barrier)
295 (sb-thread:wait-on-semaphore barrier)
296 (flet ((sched (thread)
297 (sb-thread:make-thread (lambda ()
299 do (sb-ext:schedule-timer (make-timer #'one :thread thread) 0.001))))))
300 (dolist (thread threads)
302 (mapcar #'sb-thread:join-thread threads)))))