1.0.23.21: Stack allocated conses for MIPS.
[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 (defmacro raises-timeout-p (&body body)
17   `(handler-case (progn (progn ,@body) nil)
18     (sb-ext:timeout () t)))
19
20 (with-test (:name (:timer :relative)
21             :fails-on '(and :sparc :linux))
22   (let* ((has-run-p nil)
23          (timer (make-timer (lambda () (setq has-run-p t))
24                             :name "simple timer")))
25     (schedule-timer timer 0.5)
26     (sleep 0.2)
27     (assert (not has-run-p))
28     (sleep 0.5)
29     (assert has-run-p)
30     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
31
32 (with-test (:name (:timer :absolute)
33             :fails-on '(and :sparc :linux))
34   (let* ((has-run-p nil)
35          (timer (make-timer (lambda () (setq has-run-p t))
36                             :name "simple timer")))
37     (schedule-timer timer (+ 1/2 (get-universal-time)) :absolute-p t)
38     (sleep 0.2)
39     (assert (not has-run-p))
40     (sleep 0.5)
41     (assert has-run-p)
42     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
43
44 #+sb-thread
45 (with-test (:name (:timer :other-thread))
46   (let* ((thread (sb-thread:make-thread (lambda () (sleep 2))))
47          (timer (make-timer (lambda ()
48                               (assert (eq thread sb-thread:*current-thread*)))
49                             :thread thread)))
50     (schedule-timer timer 0.1)))
51
52 #+sb-thread
53 (with-test (:name (:timer :new-thread))
54   (let* ((original-thread sb-thread:*current-thread*)
55          (timer (make-timer
56                  (lambda ()
57                    (assert (not (eq original-thread
58                                     sb-thread:*current-thread*))))
59                  :thread t)))
60     (schedule-timer timer 0.1)))
61
62 (with-test (:name (:timer :repeat-and-unschedule)
63             :fails-on '(and :sparc :linux))
64   (let* ((run-count 0)
65          timer)
66     (setq timer
67           (make-timer (lambda ()
68                         (when (= 5 (incf run-count))
69                           (unschedule-timer timer)))))
70     (schedule-timer timer 0 :repeat-interval 0.2)
71     (assert (timer-scheduled-p timer :delta 0.3))
72     (sleep 1.3)
73     (assert (= 5 run-count))
74     (assert (not (timer-scheduled-p timer)))
75     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
76
77 (with-test (:name (:timer :reschedule))
78   (let* ((has-run-p nil)
79          (timer (make-timer (lambda ()
80                               (setq has-run-p t)))))
81     (schedule-timer timer 0.2)
82     (schedule-timer timer 0.3)
83     (sleep 0.5)
84     (assert has-run-p)
85     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
86
87 (with-test (:name (:timer :stress))
88   (let ((time (1+ (get-universal-time))))
89     (loop repeat 200 do
90           (schedule-timer (make-timer (lambda ())) time :absolute-p t))
91     (sleep 2)
92     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
93
94 (with-test (:name (:with-timeout :timeout))
95   (assert (raises-timeout-p
96            (sb-ext:with-timeout 0.2
97              (sleep 1)))))
98
99 (with-test (:name (:with-timeout :fall-through))
100   (assert (not (raises-timeout-p
101                 (sb-ext:with-timeout 0.3
102                   (sleep 0.1))))))
103
104 (with-test (:name (:with-timeout :nested-timeout-smaller))
105   (assert(raises-timeout-p
106           (sb-ext:with-timeout 10
107             (sb-ext:with-timeout 0.5
108               (sleep 2))))))
109
110 (with-test (:name (:with-timeout :nested-timeout-bigger))
111   (assert(raises-timeout-p
112           (sb-ext:with-timeout 0.5
113             (sb-ext:with-timeout 2
114               (sleep 2))))))
115
116 (defun wait-for-threads (threads)
117   (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
118
119 #+sb-thread
120 (with-test (:name (:with-timeout :many-at-the-same-time))
121   (let ((ok t))
122     (let ((threads (loop repeat 10 collect
123                          (sb-thread:make-thread
124                           (lambda ()
125                             (handler-case
126                                 (sb-ext:with-timeout 0.5
127                                   (sleep 5)
128                                   (setf ok nil)
129                                   (format t "~%not ok~%"))
130                               (timeout ()
131                                 )))))))
132       (assert (not (raises-timeout-p
133                     (sb-ext:with-timeout 20
134                       (wait-for-threads threads)))))
135       (assert ok))))
136
137 #+sb-thread
138 (with-test (:name (:with-timeout :dead-thread))
139   (sb-thread:make-thread
140    (lambda ()
141      (let ((timer (make-timer (lambda ()))))
142        (schedule-timer timer 3)
143        (assert t))))
144   (sleep 6)
145   (assert t))
146
147
148 (defun random-type (n)
149   `(integer ,(random n) ,(+ n (random n))))
150
151 ;;; FIXME: Since timeouts do not work on Windows this would loop
152 ;;; forever.
153 #-win32
154 (with-test (:name (:hash-cache :interrupt))
155   (let* ((type1 (random-type 500))
156          (type2 (random-type 500))
157          (wanted (subtypep type1 type2)))
158     (dotimes (i 100)
159       (block foo
160         (sb-ext:schedule-timer (sb-ext:make-timer
161                                 (lambda ()
162                                   (assert (eq wanted (subtypep type1 type2)))
163                                     (return-from foo)))
164                                0.05)
165         (loop
166            (assert (eq wanted (subtypep type1 type2))))))))
167
168 ;;; Disabled. Hangs occasionally at least on x86. See comment before
169 ;;; the next test case.
170 #+(and nil sb-thread)
171 (with-test (:name (:timer :parallel-unschedule))
172   (let ((timer (sb-ext:make-timer (lambda () 42) :name "parallel schedulers"))
173         (other nil))
174     (flet ((flop ()
175              (sleep (random 0.01))
176              (loop repeat 10000
177                    do (sb-ext:unschedule-timer timer))))
178       (loop repeat 5
179             do (mapcar #'sb-thread:join-thread
180                        (loop for i from 1 upto 10
181                              collect (let* ((thread (sb-thread:make-thread #'flop
182                                                                            :name (format nil "scheduler ~A" i)))
183                                             (ticker (sb-ext:make-timer (lambda () 13) :thread (or other thread)
184                                                                        :name (format nil "ticker ~A" i))))
185                                        (setf other thread)
186                                        (sb-ext:schedule-timer ticker 0 :repeat-interval 0.00001)
187                                        thread)))))))
188
189 ;;;; FIXME: OS X 10.4 doesn't like these being at all, and gives us a SIGSEGV
190 ;;;; instead of using the Mach expection system! 10.5 on the other tends to
191 ;;;; lose() where with interrupt already pending. :/
192 ;;;;
193 ;;;; FIXME: This test also occasionally hangs on Linux/x86-64 at least. The
194 ;;;; common feature is one thread in gc_stop_the_world, and another trying to
195 ;;;; signal_interrupt_thread, but both (apparently) getting EAGAIN repeatedly.
196 ;;;; Exactly how or why this is happening remains under investigation -- but
197 ;;;; it seems plausible that the fast timers simply fill up the interrupt
198 ;;;; queue completely. (On some occasions the process unwedges itself after
199 ;;;; a few minutes, but not always.)
200 ;;;;
201 ;;;; FIXME: Another failure mode on Linux: recursive entries to
202 ;;;; RUN-EXPIRED-TIMERS blowing the stack.
203 #+nil
204 (with-test (:name (:timer :schedule-stress))
205   (flet ((test ()
206            (let* ((slow-timers (loop for i from 1 upto 100
207                                      collect (sb-ext:make-timer (lambda () 13) :name (format nil "slow ~A" i))))
208                   (fast-timer (sb-ext:make-timer (lambda () 42) :name "fast")))
209              (sb-ext:schedule-timer fast-timer 0.0001 :repeat-interval 0.0001)
210              (dolist (timer slow-timers)
211                (sb-ext:schedule-timer timer (random 0.1) :repeat-interval (random 0.1)))
212              (dolist (timer slow-timers)
213                (sb-ext:unschedule-timer timer))
214              (sb-ext:unschedule-timer fast-timer))))
215     #+sb-thread
216     (mapcar #'sb-thread:join-thread (loop repeat 10 collect (sb-thread:make-thread #'test)))
217     #-sb-thread
218     (loop repeat 10 do (test))))
219
220 #+sb-thread
221 (with-test (:name (:timer :threaded-stress))
222   (let ((barrier (sb-thread:make-semaphore))
223         (goal 100))
224     (flet ((wait-for-goal ()
225              (let ((*n* 0))
226                (declare (special *n*))
227                (sb-thread:signal-semaphore barrier)
228                (loop until (eql *n* goal))))
229            (one ()
230              (declare (special *n*))
231              (incf *n*)))
232       (let ((threads (list (sb-thread:make-thread #'wait-for-goal)
233                            (sb-thread:make-thread #'wait-for-goal)
234                            (sb-thread:make-thread #'wait-for-goal))))
235         (sb-thread:wait-on-semaphore barrier)
236         (sb-thread:wait-on-semaphore barrier)
237         (sb-thread:wait-on-semaphore barrier)
238         (flet ((sched (thread)
239                  (sb-thread:make-thread (lambda ()
240                                           (loop repeat goal
241                                                 do (sb-ext:schedule-timer (make-timer #'one :thread thread) 0.001))))))
242           (dolist (thread threads)
243             (sched thread)))
244         (mapcar #'sb-thread:join-thread threads)))))