X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftimer.impure.lisp;h=3f16fa12fbf6ea6bdc9fb22d1bf6ba2fa0e2ef7a;hb=9373c1691aee82e4e21379b85400c3ea363adf47;hp=8531430bbee3b1a644907b990447046e85f69e0c;hpb=35bfc07cbd9aa8029e9cc42f1a3fab27f1a673f4;p=sbcl.git diff --git a/tests/timer.impure.lisp b/tests/timer.impure.lisp index 8531430..3f16fa1 100644 --- a/tests/timer.impure.lisp +++ b/tests/timer.impure.lisp @@ -13,11 +13,69 @@ (use-package :test-util) +(sb-alien:define-alien-routine "check_deferrables_blocked_or_lose" + void) +(sb-alien:define-alien-routine "check_deferrables_unblocked_or_lose" + void) + +(defun make-limited-timer (fn n &rest args) + (let (timer) + (setq timer + (apply #'sb-ext:make-timer + (lambda () + (sb-sys:without-interrupts + (decf n) + (cond ((minusp n) + (warn "Unscheduling timer ~A ~ + upon reaching run limit. System too slow?" + timer) + (sb-ext:unschedule-timer timer)) + (t + (sb-sys:allow-with-interrupts + (funcall fn)))))) + args)))) + +(defun make-and-schedule-and-wait (fn time) + (let ((finishedp nil)) + (sb-ext:schedule-timer (sb-ext:make-timer + (lambda () + (sb-sys:without-interrupts + (unwind-protect + (sb-sys:allow-with-interrupts + (funcall fn)) + (setq finishedp t))))) + time) + (loop until finishedp))) + +(with-test (:name (:timer :deferrables-blocked)) + (make-and-schedule-and-wait (lambda () + (check-deferrables-blocked-or-lose)) + (random 0.1)) + (check-deferrables-unblocked-or-lose)) + +(with-test (:name (:timer :deferrables-unblocked)) + (make-and-schedule-and-wait (lambda () + (sb-sys:with-interrupts + (check-deferrables-unblocked-or-lose))) + (random 0.1)) + (check-deferrables-unblocked-or-lose)) + +#-win32 +(with-test (:name (:timer :deferrables-unblocked :unwind)) + (catch 'xxx + (make-and-schedule-and-wait (lambda () + (check-deferrables-blocked-or-lose) + (throw 'xxx nil)) + (random 0.1)) + (sleep 1)) + (check-deferrables-unblocked-or-lose)) + (defmacro raises-timeout-p (&body body) `(handler-case (progn (progn ,@body) nil) (sb-ext:timeout () t))) -(with-test (:name (:timer :relative)) +(with-test (:name (:timer :relative) + :fails-on '(and :sparc :linux)) (let* ((has-run-p nil) (timer (make-timer (lambda () (setq has-run-p t)) :name "simple timer"))) @@ -28,7 +86,8 @@ (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 (make-timer (lambda () (setq has-run-p t)) :name "simple timer"))) @@ -57,7 +116,8 @@ :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 @@ -145,7 +205,10 @@ (defun random-type (n) `(integer ,(random n) ,(+ n (random n)))) -(with-test (:name '(:hash-cache :interrupt)) +;;; 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))) @@ -158,3 +221,82 @@ 0.05) (loop (assert (eq wanted (subtypep type1 type2)))))))) + +;;; Used to hang occasionally at least on x86. Two bugs caused it: +;;; running out of stack (due to repeating timers being rescheduled +;;; before they ran) and dying threads were open interrupts. +#+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 (make-limited-timer (lambda () 13) + 1000 + :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() here with interrupt already pending. :/ +;;;; +;;;; Used to have problems in genereal, see comment on (:TIMER +;;;; :PARALLEL-UNSCHEDULE). +(with-test (:name (:timer :schedule-stress)) + (flet ((test () + (let* ((slow-timers + (loop for i from 1 upto 1 + collect (make-limited-timer + (lambda () 13) + 1000 + :name (format nil "slow ~A" i)))) + (fast-timer (make-limited-timer (lambda () 42) 1000 + :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)))))