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 (with-test (:name :heap)
18 (heap (make-array size :adjustable t :fill-pointer 0))
19 (unsorted (loop for i below size collect (random size)))
20 (sorted (sort (copy-list unsorted) #'>=))
22 (map nil #'(lambda (val) (sb-impl::heap-insert heap val)) unsorted)
23 (setf heap-sorted (loop for i below size
24 collect (sb-impl::heap-extract-maximum heap)))
25 (unless (equal sorted heap-sorted)
26 (error "Heap sort failure ~S" heap-sorted))))
28 (sb-alien:define-alien-routine "check_deferrables_blocked_or_lose"
30 (where sb-alien:unsigned-long))
31 (sb-alien:define-alien-routine "check_deferrables_unblocked_or_lose"
33 (where sb-alien:unsigned-long))
35 (defun make-limited-timer (fn n &rest args)
38 (apply #'sb-ext:make-timer
40 (sb-sys:without-interrupts
43 (warn "Unscheduling timer ~A ~
44 upon reaching run limit. System too slow?"
46 (sb-ext:unschedule-timer timer))
48 (sb-sys:allow-with-interrupts
52 (defun make-and-schedule-and-wait (fn time)
53 (let ((finishedp nil))
54 (sb-ext:schedule-timer (sb-ext:make-timer
56 (sb-sys:without-interrupts
58 (sb-sys:allow-with-interrupts
60 (setq finishedp t)))))
62 (loop until finishedp)))
65 (with-test (:name (:timer :deferrables-blocked))
66 (make-and-schedule-and-wait (lambda ()
67 (check-deferrables-blocked-or-lose 0))
69 (check-deferrables-unblocked-or-lose 0))
72 (with-test (:name (:timer :deferrables-unblocked))
73 (make-and-schedule-and-wait (lambda ()
74 (sb-sys:with-interrupts
75 (check-deferrables-unblocked-or-lose 0)))
77 (check-deferrables-unblocked-or-lose 0))
80 (with-test (:name (:timer :deferrables-unblocked :unwind))
82 (make-and-schedule-and-wait (lambda ()
83 (check-deferrables-blocked-or-lose 0)
87 (check-deferrables-unblocked-or-lose 0))
89 (defmacro raises-timeout-p (&body body)
90 `(handler-case (progn (progn ,@body) nil)
91 (sb-ext:timeout () t)))
94 (with-test (:name (:timer :relative)
95 :fails-on '(and :sparc :linux))
96 (let* ((has-run-p nil)
97 (timer (make-timer (lambda () (setq has-run-p t))
98 :name "simple timer")))
99 (schedule-timer timer 0.5)
101 (assert (not has-run-p))
104 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
107 (with-test (:name (:timer :absolute)
108 :fails-on '(and :sparc :linux))
109 (let* ((has-run-p nil)
110 (timer (make-timer (lambda () (setq has-run-p t))
111 :name "simple timer")))
112 (schedule-timer timer (+ 1/2 (get-universal-time)) :absolute-p t)
114 (assert (not has-run-p))
117 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
120 (with-test (:name (:timer :other-thread))
121 (let* ((thread (sb-thread:make-thread (lambda () (sleep 2))))
122 (timer (make-timer (lambda ()
123 (assert (eq thread sb-thread:*current-thread*)))
125 (schedule-timer timer 0.1)))
128 (with-test (:name (:timer :new-thread))
129 (let* ((original-thread sb-thread:*current-thread*)
132 (assert (not (eq original-thread
133 sb-thread:*current-thread*))))
135 (schedule-timer timer 0.1)))
138 (with-test (:name (:timer :repeat-and-unschedule)
139 :fails-on '(and :sparc :linux))
143 (make-timer (lambda ()
144 (when (= 5 (incf run-count))
145 (unschedule-timer timer)))))
146 (schedule-timer timer 0 :repeat-interval 0.2)
147 (assert (timer-scheduled-p timer :delta 0.3))
149 (assert (= 5 run-count))
150 (assert (not (timer-scheduled-p timer)))
151 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
154 (with-test (:name (:timer :reschedule))
155 (let* ((has-run-p nil)
156 (timer (make-timer (lambda ()
157 (setq has-run-p t)))))
158 (schedule-timer timer 0.2)
159 (schedule-timer timer 0.3)
162 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
165 (with-test (:name (:timer :stress))
166 (let ((time (1+ (get-universal-time))))
168 (schedule-timer (make-timer (lambda ())) time :absolute-p t))
170 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
173 (with-test (:name (:timer :stress2))
174 (let ((time (1+ (get-universal-time)))
176 (loop for time-n from time upto (+ 1/10 time) by (/ 1/10 200)
177 do (schedule-timer (make-timer (lambda ())) time-n :absolute-p t)
180 (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
183 (with-test (:name (:with-timeout :timeout))
184 (assert (raises-timeout-p
185 (sb-ext:with-timeout 0.2
189 (with-test (:name (:with-timeout :fall-through))
190 (assert (not (raises-timeout-p
191 (sb-ext:with-timeout 0.3
195 (with-test (:name (:with-timeout :nested-timeout-smaller))
196 (assert(raises-timeout-p
197 (sb-ext:with-timeout 10
198 (sb-ext:with-timeout 0.5
202 (with-test (:name (:with-timeout :nested-timeout-bigger))
203 (assert(raises-timeout-p
204 (sb-ext:with-timeout 0.5
205 (sb-ext:with-timeout 2
208 (defun wait-for-threads (threads)
209 (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
212 (with-test (:name (:with-timeout :many-at-the-same-time))
214 (let ((threads (loop repeat 10 collect
215 (sb-thread:make-thread
218 (sb-ext:with-timeout 0.5
221 (format t "~%not ok~%"))
224 (assert (not (raises-timeout-p
225 (sb-ext:with-timeout 20
226 (wait-for-threads threads)))))
230 (with-test (:name (:with-timeout :dead-thread))
231 (sb-thread:make-thread
233 (let ((timer (make-timer (lambda ()))))
234 (schedule-timer timer 3)
240 (defun random-type (n)
241 `(integer ,(random n) ,(+ n (random n))))
243 ;;; FIXME: Since timeouts do not work on Windows this would loop
246 (with-test (:name (:hash-cache :interrupt))
247 (let* ((type1 (random-type 500))
248 (type2 (random-type 500))
249 (wanted (subtypep type1 type2)))
252 (sb-ext:schedule-timer (sb-ext:make-timer
254 (assert (eq wanted (subtypep type1 type2)))
258 (assert (eq wanted (subtypep type1 type2))))))))
260 ;;; Used to hang occasionally at least on x86. Two bugs caused it:
261 ;;; running out of stack (due to repeating timers being rescheduled
262 ;;; before they ran) and dying threads were open interrupts.
264 (with-test (:name (:timer :parallel-unschedule) :fails-on :ppc)
266 (error "Prone to hang on Darwin due to interrupt issues.")
268 (error "Prone to hang the host on linux/ppc for unknown reasons.")
269 (let ((timer (sb-ext:make-timer (lambda () 42) :name "parallel schedulers"))
272 (sleep (random 0.01))
274 do (sb-ext:unschedule-timer timer))))
276 do (mapcar #'sb-thread:join-thread
277 (loop for i from 1 upto 10
278 collect (let* ((thread (sb-thread:make-thread #'flop
279 :name (format nil "scheduler ~A" i)))
280 (ticker (make-limited-timer (lambda () 13)
282 :thread (or other thread)
283 :name (format nil "ticker ~A" i))))
285 (sb-ext:schedule-timer ticker 0 :repeat-interval 0.00001)
288 ;;;; FIXME: OS X 10.4 doesn't like these being at all, and gives us a SIGSEGV
289 ;;;; instead of using the Mach expection system! 10.5 on the other tends to
290 ;;;; lose() here with interrupt already pending. :/
292 ;;;; Used to have problems in genereal, see comment on (:TIMER
293 ;;;; :PARALLEL-UNSCHEDULE).
295 (with-test (:name (:timer :schedule-stress))
298 (loop for i from 1 upto 1
299 collect (make-limited-timer
302 :name (format nil "slow ~A" i))))
303 (fast-timer (make-limited-timer (lambda () 42) 1000
305 (sb-ext:schedule-timer fast-timer 0.0001 :repeat-interval 0.0001)
306 (dolist (timer slow-timers)
307 (sb-ext:schedule-timer timer (random 0.1)
308 :repeat-interval (random 0.1)))
309 (dolist (timer slow-timers)
310 (sb-ext:unschedule-timer timer))
311 (sb-ext:unschedule-timer fast-timer))))
313 (mapcar #'sb-thread:join-thread
314 (loop repeat 10 collect (sb-thread:make-thread #'test)))
316 (loop repeat 10 do (test))))
319 (with-test (:name (:timer :threaded-stress))
320 (let ((barrier (sb-thread:make-semaphore))
322 (flet ((wait-for-goal ()
324 (declare (special *n*))
325 (sb-thread:signal-semaphore barrier)
326 (loop until (eql *n* goal))))
328 (declare (special *n*))
330 (let ((threads (list (sb-thread:make-thread #'wait-for-goal)
331 (sb-thread:make-thread #'wait-for-goal)
332 (sb-thread:make-thread #'wait-for-goal))))
333 (sb-thread:wait-on-semaphore barrier)
334 (sb-thread:wait-on-semaphore barrier)
335 (sb-thread:wait-on-semaphore barrier)
336 (flet ((sched (thread)
337 (sb-thread:make-thread (lambda ()
339 do (sb-ext:schedule-timer (make-timer #'one :thread thread) 0.001))))))
340 (dolist (thread threads)
342 (mapcar #'sb-thread:join-thread threads)))))