(use-package :test-util)
-(with-test (:name (:timer :relative))
+(defmacro raises-timeout-p (&body body)
+ `(handler-case (progn (progn ,@body) nil)
+ (sb-ext:timeout () t)))
+
+(with-test (:name (:timer :relative)
+ :fails-on '(and :sparc :linux))
(let* ((has-run-p nil)
- (timer (sb-impl::make-timer (lambda () (setq has-run-p t))
+ (timer (make-timer (lambda () (setq has-run-p t))
:name "simple timer")))
- (sb-impl::schedule-timer timer 0.5)
+ (schedule-timer timer 0.5)
(sleep 0.2)
(assert (not has-run-p))
(sleep 0.5)
(assert has-run-p)
(assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
-(with-test (:name (:timer :absolute))
+(with-test (:name (:timer :absolute)
+ :fails-on '(and :sparc :linux))
(let* ((has-run-p nil)
- (timer (sb-impl::make-timer (lambda () (setq has-run-p t))
+ (timer (make-timer (lambda () (setq has-run-p t))
:name "simple timer")))
- (sb-impl::schedule-timer timer (+ 1/2 (get-universal-time))
- :absolute-p t)
+ (schedule-timer timer (+ 1/2 (get-universal-time)) :absolute-p t)
(sleep 0.2)
(assert (not has-run-p))
(sleep 0.5)
(assert has-run-p)
(assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
-(defvar *x* nil)
-
#+sb-thread
(with-test (:name (:timer :other-thread))
- (let* ((thread (sb-thread:make-thread (lambda () (let ((*x* t)) (sleep 2)))))
- (timer (sb-impl::make-timer (lambda () (assert *x*)) :thread thread)))
- (sb-impl::schedule-timer timer 0.1)))
+ (let* ((thread (sb-thread:make-thread (lambda () (sleep 2))))
+ (timer (make-timer (lambda ()
+ (assert (eq thread sb-thread:*current-thread*)))
+ :thread thread)))
+ (schedule-timer timer 0.1)))
#+sb-thread
(with-test (:name (:timer :new-thread))
- (let ((*x* t)
- (timer (sb-impl::make-timer (lambda () (assert (not *x*))) :thread t)))
- (sb-impl::schedule-timer timer 0.1)))
+ (let* ((original-thread sb-thread:*current-thread*)
+ (timer (make-timer
+ (lambda ()
+ (assert (not (eq original-thread
+ sb-thread:*current-thread*))))
+ :thread t)))
+ (schedule-timer timer 0.1)))
-(with-test (:name (:timer :repeat-and-unschedule))
+(with-test (:name (:timer :repeat-and-unschedule)
+ :fails-on '(and :sparc :linux))
(let* ((run-count 0)
timer)
(setq timer
- (sb-impl::make-timer (lambda ()
+ (make-timer (lambda ()
(when (= 5 (incf run-count))
- (sb-impl::unschedule-timer timer)))))
- (sb-impl::schedule-timer timer 0 :repeat-interval 0.2)
- (assert (not (sb-impl::timer-expired-p timer 0.3)))
+ (unschedule-timer timer)))))
+ (schedule-timer timer 0 :repeat-interval 0.2)
+ (assert (timer-scheduled-p timer :delta 0.3))
(sleep 1.3)
(assert (= 5 run-count))
- (assert (sb-impl::timer-expired-p timer))
+ (assert (not (timer-scheduled-p timer)))
(assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
(with-test (:name (:timer :reschedule))
(let* ((has-run-p nil)
- (timer (sb-impl::make-timer (lambda ()
+ (timer (make-timer (lambda ()
(setq has-run-p t)))))
- (sb-impl::schedule-timer timer 0.2)
- (sb-impl::schedule-timer timer 0.3)
+ (schedule-timer timer 0.2)
+ (schedule-timer timer 0.3)
(sleep 0.5)
(assert has-run-p)
(assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
(with-test (:name (:timer :stress))
(let ((time (1+ (get-universal-time))))
(loop repeat 200 do
- (sb-impl::schedule-timer (sb-impl::make-timer (lambda ())) time
- :absolute-p t))
+ (schedule-timer (make-timer (lambda ())) time :absolute-p t))
(sleep 2)
(assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
-(defmacro raises-timeout-p (&body body)
- `(handler-case (progn (progn ,@body) nil)
- (sb-ext:timeout () t)))
-
(with-test (:name (:with-timeout :timeout))
(assert (raises-timeout-p
(sb-ext:with-timeout 0.2
(sb-ext:with-timeout 0.5
(sb-ext:with-timeout 2
(sleep 2))))))
+
+(defun wait-for-threads (threads)
+ (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
+
+#+sb-thread
+(with-test (:name (:with-timeout :many-at-the-same-time))
+ (let ((ok t))
+ (let ((threads (loop repeat 10 collect
+ (sb-thread:make-thread
+ (lambda ()
+ (handler-case
+ (sb-ext:with-timeout 0.5
+ (sleep 5)
+ (setf ok nil)
+ (format t "~%not ok~%"))
+ (timeout ()
+ )))))))
+ (assert (not (raises-timeout-p
+ (sb-ext:with-timeout 20
+ (wait-for-threads threads)))))
+ (assert ok))))
+
+#+sb-thread
+(with-test (:name (:with-timeout :dead-thread))
+ (sb-thread:make-thread
+ (lambda ()
+ (let ((timer (make-timer (lambda ()))))
+ (schedule-timer timer 3)
+ (assert t))))
+ (sleep 6)
+ (assert t))
+
+
+(defun random-type (n)
+ `(integer ,(random n) ,(+ n (random n))))
+
+;;; FIXME: Since timeouts do not work on Windows this would loop
+;;; forever.
+#-win32
+(with-test (:name (:hash-cache :interrupt))
+ (let* ((type1 (random-type 500))
+ (type2 (random-type 500))
+ (wanted (subtypep type1 type2)))
+ (dotimes (i 100)
+ (block foo
+ (sb-ext:schedule-timer (sb-ext:make-timer
+ (lambda ()
+ (assert (eq wanted (subtypep type1 type2)))
+ (return-from foo)))
+ 0.05)
+ (loop
+ (assert (eq wanted (subtypep type1 type2))))))))
+
+#+sb-thread
+(with-test (:name (:timer :parallel-unschedule))
+ (let ((timer (sb-ext:make-timer (lambda () 42) :name "parallel schedulers"))
+ (other nil))
+ (flet ((flop ()
+ (sleep (random 0.01))
+ (loop repeat 10000
+ do (sb-ext:unschedule-timer timer))))
+ (loop repeat 5
+ do (mapcar #'sb-thread:join-thread
+ (loop for i from 1 upto 10
+ collect (let* ((thread (sb-thread:make-thread #'flop
+ :name (format nil "scheduler ~A" i)))
+ (ticker (sb-ext:make-timer (lambda () 13) :thread (or other thread)
+ :name (format nil "ticker ~A" i))))
+ (setf other thread)
+ (sb-ext:schedule-timer ticker 0 :repeat-interval 0.00001)
+ thread)))))))
+
+;;;; FIXME: OS X 10.4 doesn't like these being at all, and gives us a SIGSEGV
+;;;; instead of using the Mach expection system! 10.5 on the other tends to
+;;;; lose() where with interrupt already pending. :/
+;;;;
+;;;; FIXME: This test also occasionally hangs on Linux/x86-64 at least. The
+;;;; common feature is one thread in gc_stop_the_world, and another trying to
+;;;; signal_interrupt_thread, but both (apparently) getting EAGAIN repeatedly.
+;;;; Exactly how or why this is happening remains under investigation -- but
+;;;; it seems plausible that the fast timers simply fill up the interrupt
+;;;; queue completely. (On some occasions the process unwedges itself after
+;;;; a few minutes, but not always.)
+;;;;
+;;;; FIXME: Another failure mode on Linux: recursive entries to
+;;;; RUN-EXPIRED-TIMERS blowing the stack.
+#+nil
+(with-test (:name (:timer :schedule-stress))
+ (flet ((test ()
+ (let* ((slow-timers (loop for i from 1 upto 100
+ collect (sb-ext:make-timer (lambda () 13) :name (format nil "slow ~A" i))))
+ (fast-timer (sb-ext:make-timer (lambda () 42) :name "fast")))
+ (sb-ext:schedule-timer fast-timer 0.0001 :repeat-interval 0.0001)
+ (dolist (timer slow-timers)
+ (sb-ext:schedule-timer timer (random 0.1) :repeat-interval (random 0.1)))
+ (dolist (timer slow-timers)
+ (sb-ext:unschedule-timer timer))
+ (sb-ext:unschedule-timer fast-timer))))
+ #+sb-thread
+ (mapcar #'sb-thread:join-thread (loop repeat 10 collect (sb-thread:make-thread #'test)))
+ #-sb-thread
+ (loop repeat 10 do (test))))
+
+#+sb-thread
+(with-test (:name (:timer :threaded-stress))
+ (let ((barrier (sb-thread:make-semaphore))
+ (goal 100))
+ (flet ((wait-for-goal ()
+ (let ((*n* 0))
+ (declare (special *n*))
+ (sb-thread:signal-semaphore barrier)
+ (loop until (eql *n* goal))))
+ (one ()
+ (declare (special *n*))
+ (incf *n*)))
+ (let ((threads (list (sb-thread:make-thread #'wait-for-goal)
+ (sb-thread:make-thread #'wait-for-goal)
+ (sb-thread:make-thread #'wait-for-goal))))
+ (sb-thread:wait-on-semaphore barrier)
+ (sb-thread:wait-on-semaphore barrier)
+ (sb-thread:wait-on-semaphore barrier)
+ (flet ((sched (thread)
+ (sb-thread:make-thread (lambda ()
+ (loop repeat goal
+ do (sb-ext:schedule-timer (make-timer #'one :thread thread) 0.001))))))
+ (dolist (thread threads)
+ (sched thread)))
+ (mapcar #'sb-thread:join-thread threads)))))