X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftimer.impure.lisp;h=3cea11c68394159106a317a5c96dd1414cdd6677;hb=f81f78b9a2a4ec8e2bef6074de121885c6f19e44;hp=d07a7a046b42e5d1c7f22aa07c3d91d6aca12e6d;hpb=40a26a4dd7f2891e78421ba465b99bb67f892856;p=sbcl.git diff --git a/tests/timer.impure.lisp b/tests/timer.impure.lisp index d07a7a0..3cea11c 100644 --- a/tests/timer.impure.lisp +++ b/tests/timer.impure.lisp @@ -13,63 +13,73 @@ (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*)))))) @@ -77,15 +87,10 @@ (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 @@ -107,3 +112,133 @@ (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)))))))) + +;;; Disabled. Hangs occasionally at least on x86. See comment before +;;; the next test case. +#+(and nil 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)))))