1.0.39: will be tagged as sbcl_1_0_39
[sbcl.git] / tests / timer.impure.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3 ;;;;
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
6 ;;;; from CMU CL.
7 ;;;;
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.
11
12 (in-package "CL-USER")
13
14 (use-package :test-util)
15
16 (with-test (:name :heap)
17   (let* ((size 1000)
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) #'>=))
21          heap-sorted)
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))))
27
28 (sb-alien:define-alien-routine "check_deferrables_blocked_or_lose"
29     void
30   (where sb-alien:unsigned-long))
31 (sb-alien:define-alien-routine "check_deferrables_unblocked_or_lose"
32     void
33   (where sb-alien:unsigned-long))
34
35 (defun make-limited-timer (fn n &rest args)
36   (let (timer)
37     (setq timer
38           (apply #'sb-ext:make-timer
39                  (lambda ()
40                    (sb-sys:without-interrupts
41                      (decf n)
42                      (cond ((minusp n)
43                             (warn "Unscheduling timer ~A ~
44                                    upon reaching run limit. System too slow?"
45                                   timer)
46                             (sb-ext:unschedule-timer timer))
47                            (t
48                             (sb-sys:allow-with-interrupts
49                               (funcall fn))))))
50                  args))))
51
52 (defun make-and-schedule-and-wait (fn time)
53   (let ((finishedp nil))
54     (sb-ext:schedule-timer (sb-ext:make-timer
55                             (lambda ()
56                               (sb-sys:without-interrupts
57                                 (unwind-protect
58                                      (sb-sys:allow-with-interrupts
59                                        (funcall fn))
60                                   (setq finishedp t)))))
61                            time)
62     (loop until finishedp)))
63
64 (with-test (:name (:timer :deferrables-blocked))
65   (make-and-schedule-and-wait (lambda ()
66                                 (check-deferrables-blocked-or-lose 0))
67                               (random 0.1))
68   (check-deferrables-unblocked-or-lose 0))
69
70 (with-test (:name (:timer :deferrables-unblocked))
71   (make-and-schedule-and-wait (lambda ()
72                                 (sb-sys:with-interrupts
73                                   (check-deferrables-unblocked-or-lose 0)))
74                               (random 0.1))
75   (check-deferrables-unblocked-or-lose 0))
76
77 #-win32
78 (with-test (:name (:timer :deferrables-unblocked :unwind))
79   (catch 'xxx
80     (make-and-schedule-and-wait (lambda ()
81                                   (check-deferrables-blocked-or-lose 0)
82                                   (throw 'xxx nil))
83                                 (random 0.1))
84     (sleep 1))
85   (check-deferrables-unblocked-or-lose 0))
86
87 (defmacro raises-timeout-p (&body body)
88   `(handler-case (progn (progn ,@body) nil)
89     (sb-ext:timeout () t)))
90
91 (with-test (:name (:timer :relative)
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 0.5)
97     (sleep 0.2)
98     (assert (not has-run-p))
99     (sleep 0.5)
100     (assert has-run-p)
101     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
102
103 (with-test (:name (:timer :absolute)
104             :fails-on '(and :sparc :linux))
105   (let* ((has-run-p nil)
106          (timer (make-timer (lambda () (setq has-run-p t))
107                             :name "simple timer")))
108     (schedule-timer timer (+ 1/2 (get-universal-time)) :absolute-p t)
109     (sleep 0.2)
110     (assert (not has-run-p))
111     (sleep 0.5)
112     (assert has-run-p)
113     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
114
115 #+sb-thread
116 (with-test (:name (:timer :other-thread))
117   (let* ((thread (sb-thread:make-thread (lambda () (sleep 2))))
118          (timer (make-timer (lambda ()
119                               (assert (eq thread sb-thread:*current-thread*)))
120                             :thread thread)))
121     (schedule-timer timer 0.1)))
122
123 #+sb-thread
124 (with-test (:name (:timer :new-thread))
125   (let* ((original-thread sb-thread:*current-thread*)
126          (timer (make-timer
127                  (lambda ()
128                    (assert (not (eq original-thread
129                                     sb-thread:*current-thread*))))
130                  :thread t)))
131     (schedule-timer timer 0.1)))
132
133 (with-test (:name (:timer :repeat-and-unschedule)
134             :fails-on '(and :sparc :linux))
135   (let* ((run-count 0)
136          timer)
137     (setq timer
138           (make-timer (lambda ()
139                         (when (= 5 (incf run-count))
140                           (unschedule-timer timer)))))
141     (schedule-timer timer 0 :repeat-interval 0.2)
142     (assert (timer-scheduled-p timer :delta 0.3))
143     (sleep 1.3)
144     (assert (= 5 run-count))
145     (assert (not (timer-scheduled-p timer)))
146     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
147
148 (with-test (:name (:timer :reschedule))
149   (let* ((has-run-p nil)
150          (timer (make-timer (lambda ()
151                               (setq has-run-p t)))))
152     (schedule-timer timer 0.2)
153     (schedule-timer timer 0.3)
154     (sleep 0.5)
155     (assert has-run-p)
156     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
157
158 (with-test (:name (:timer :stress))
159   (let ((time (1+ (get-universal-time))))
160     (loop repeat 200 do
161           (schedule-timer (make-timer (lambda ())) time :absolute-p t))
162     (sleep 2)
163     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
164
165 (with-test (:name (:with-timeout :timeout))
166   (assert (raises-timeout-p
167            (sb-ext:with-timeout 0.2
168              (sleep 1)))))
169
170 (with-test (:name (:with-timeout :fall-through))
171   (assert (not (raises-timeout-p
172                 (sb-ext:with-timeout 0.3
173                   (sleep 0.1))))))
174
175 (with-test (:name (:with-timeout :nested-timeout-smaller))
176   (assert(raises-timeout-p
177           (sb-ext:with-timeout 10
178             (sb-ext:with-timeout 0.5
179               (sleep 2))))))
180
181 (with-test (:name (:with-timeout :nested-timeout-bigger))
182   (assert(raises-timeout-p
183           (sb-ext:with-timeout 0.5
184             (sb-ext:with-timeout 2
185               (sleep 2))))))
186
187 (defun wait-for-threads (threads)
188   (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
189
190 #+sb-thread
191 (with-test (:name (:with-timeout :many-at-the-same-time))
192   (let ((ok t))
193     (let ((threads (loop repeat 10 collect
194                          (sb-thread:make-thread
195                           (lambda ()
196                             (handler-case
197                                 (sb-ext:with-timeout 0.5
198                                   (sleep 5)
199                                   (setf ok nil)
200                                   (format t "~%not ok~%"))
201                               (timeout ()
202                                 )))))))
203       (assert (not (raises-timeout-p
204                     (sb-ext:with-timeout 20
205                       (wait-for-threads threads)))))
206       (assert ok))))
207
208 #+sb-thread
209 (with-test (:name (:with-timeout :dead-thread))
210   (sb-thread:make-thread
211    (lambda ()
212      (let ((timer (make-timer (lambda ()))))
213        (schedule-timer timer 3)
214        (assert t))))
215   (sleep 6)
216   (assert t))
217
218
219 (defun random-type (n)
220   `(integer ,(random n) ,(+ n (random n))))
221
222 ;;; FIXME: Since timeouts do not work on Windows this would loop
223 ;;; forever.
224 #-win32
225 (with-test (:name (:hash-cache :interrupt))
226   (let* ((type1 (random-type 500))
227          (type2 (random-type 500))
228          (wanted (subtypep type1 type2)))
229     (dotimes (i 100)
230       (block foo
231         (sb-ext:schedule-timer (sb-ext:make-timer
232                                 (lambda ()
233                                   (assert (eq wanted (subtypep type1 type2)))
234                                     (return-from foo)))
235                                0.05)
236         (loop
237            (assert (eq wanted (subtypep type1 type2))))))))
238
239 ;;; Used to hang occasionally at least on x86. Two bugs caused it:
240 ;;; running out of stack (due to repeating timers being rescheduled
241 ;;; before they ran) and dying threads were open interrupts.
242 #+sb-thread
243 (with-test (:name (:timer :parallel-unschedule))
244   #+darwin
245   (error "Prone to hang on Darwin due to interrupt issues.")
246   (let ((timer (sb-ext:make-timer (lambda () 42) :name "parallel schedulers"))
247         (other nil))
248     (flet ((flop ()
249              (sleep (random 0.01))
250              (loop repeat 10000
251                    do (sb-ext:unschedule-timer timer))))
252       (loop repeat 5
253             do (mapcar #'sb-thread:join-thread
254                        (loop for i from 1 upto 10
255                              collect (let* ((thread (sb-thread:make-thread #'flop
256                                                                            :name (format nil "scheduler ~A" i)))
257                                             (ticker (make-limited-timer (lambda () 13)
258                                                                                1000
259                                                                                :thread (or other thread)
260                                                                                :name (format nil "ticker ~A" i))))
261                                        (setf other thread)
262                                        (sb-ext:schedule-timer ticker 0 :repeat-interval 0.00001)
263                                        thread)))))))
264
265 ;;;; FIXME: OS X 10.4 doesn't like these being at all, and gives us a SIGSEGV
266 ;;;; instead of using the Mach expection system! 10.5 on the other tends to
267 ;;;; lose() here with interrupt already pending. :/
268 ;;;;
269 ;;;; Used to have problems in genereal, see comment on (:TIMER
270 ;;;; :PARALLEL-UNSCHEDULE).
271 (with-test (:name (:timer :schedule-stress))
272   (flet ((test ()
273          (let* ((slow-timers
274                  (loop for i from 1 upto 1
275                        collect (make-limited-timer
276                                 (lambda () 13)
277                                 1000
278                                 :name (format nil "slow ~A" i))))
279                 (fast-timer (make-limited-timer (lambda () 42) 1000
280                                                 :name "fast")))
281            (sb-ext:schedule-timer fast-timer 0.0001 :repeat-interval 0.0001)
282            (dolist (timer slow-timers)
283              (sb-ext:schedule-timer timer (random 0.1)
284                                     :repeat-interval (random 0.1)))
285            (dolist (timer slow-timers)
286              (sb-ext:unschedule-timer timer))
287            (sb-ext:unschedule-timer fast-timer))))
288   #+sb-thread
289   (mapcar #'sb-thread:join-thread
290           (loop repeat 10 collect (sb-thread:make-thread #'test)))
291   #-sb-thread
292   (loop repeat 10 do (test))))
293
294 #+sb-thread
295 (with-test (:name (:timer :threaded-stress))
296   (let ((barrier (sb-thread:make-semaphore))
297         (goal 100))
298     (flet ((wait-for-goal ()
299              (let ((*n* 0))
300                (declare (special *n*))
301                (sb-thread:signal-semaphore barrier)
302                (loop until (eql *n* goal))))
303            (one ()
304              (declare (special *n*))
305              (incf *n*)))
306       (let ((threads (list (sb-thread:make-thread #'wait-for-goal)
307                            (sb-thread:make-thread #'wait-for-goal)
308                            (sb-thread:make-thread #'wait-for-goal))))
309         (sb-thread:wait-on-semaphore barrier)
310         (sb-thread:wait-on-semaphore barrier)
311         (sb-thread:wait-on-semaphore barrier)
312         (flet ((sched (thread)
313                  (sb-thread:make-thread (lambda ()
314                                           (loop repeat goal
315                                                 do (sb-ext:schedule-timer (make-timer #'one :thread thread) 0.001))))))
316           (dolist (thread threads)
317             (sched thread)))
318         (mapcar #'sb-thread:join-thread threads)))))