X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=f32588e9d10953090ea0841231e3a12a87d74e64;hb=5e55f426de8fa579a0d6cfbfb3ac5433d530d3c9;hp=9db5021388c6f3e8bbfdac3dfd38fe3def0820bb;hpb=9373c1691aee82e4e21379b85400c3ea363adf47;p=sbcl.git diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 9db5021..f32588e 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -43,28 +43,30 @@ mutex)) (sb-alien:define-alien-routine "check_deferrables_blocked_or_lose" - void) + void + (where sb-alien:unsigned-long)) (sb-alien:define-alien-routine "check_deferrables_unblocked_or_lose" - void) + void + (where sb-alien:unsigned-long)) (with-test (:name (:interrupt-thread :deferrables-blocked)) (sb-thread:interrupt-thread sb-thread:*current-thread* (lambda () - (check-deferrables-blocked-or-lose)))) + (check-deferrables-blocked-or-lose 0)))) (with-test (:name (:interrupt-thread :deferrables-unblocked)) (sb-thread:interrupt-thread sb-thread:*current-thread* (lambda () (with-interrupts - (check-deferrables-unblocked-or-lose))))) + (check-deferrables-unblocked-or-lose 0))))) (with-test (:name (:interrupt-thread :nlx)) (catch 'xxx (sb-thread:interrupt-thread sb-thread:*current-thread* (lambda () - (check-deferrables-blocked-or-lose) + (check-deferrables-blocked-or-lose 0) (throw 'xxx nil)))) - (check-deferrables-unblocked-or-lose)) + (check-deferrables-unblocked-or-lose 0)) #-sb-thread (sb-ext:quit :unix-status 104) @@ -75,9 +77,9 @@ (sb-thread::get-spinlock spinlock) (sb-thread:interrupt-thread thread (lambda () - (check-deferrables-blocked-or-lose) + (check-deferrables-blocked-or-lose 0) (sb-thread::get-spinlock spinlock) - (check-deferrables-unblocked-or-lose) + (check-deferrables-unblocked-or-lose 0) (sb-ext:quit))) (sleep 1) (sb-thread::release-spinlock spinlock))) @@ -454,7 +456,8 @@ (format t "~&interrupt test done~%") -(defparameter *interrupt-count* 0) +(defstruct counter (n 0 :type sb-vm:word)) +(defvar *interrupt-counter* (make-counter)) (declaim (notinline check-interrupt-count)) (defun check-interrupt-count (i) @@ -469,16 +472,16 @@ (princ cond) (sb-debug:backtrace most-positive-fixnum)))) - (loop (check-interrupt-count *interrupt-count*))))))) + (loop (check-interrupt-count (counter-n *interrupt-counter*)))))))) (let ((func (lambda () (princ ".") (force-output) - (sb-impl::atomic-incf/symbol *interrupt-count*)))) - (setq *interrupt-count* 0) + (sb-ext:atomic-incf (counter-n *interrupt-counter*))))) + (setf (counter-n *interrupt-counter*) 0) (dotimes (i 100) (sleep (random 0.1d0)) (interrupt-thread c func)) - (loop until (= *interrupt-count* 100) do (sleep 0.1)) + (loop until (= (counter-n *interrupt-counter*) 100) do (sleep 0.1)) (terminate-thread c) (wait-for-threads (list c)))) @@ -871,6 +874,9 @@ | (mp:make-process #'roomy))) |# +;;; KLUDGE: No deadlines while waiting on lutex-based condition variables. This test +;;; would just hang. +#-sb-lutex (with-test (:name (:condition-variable :wait-multiple)) (loop repeat 40 do (let ((waitqueue (sb-thread:make-waitqueue :name "Q")) @@ -930,6 +936,96 @@ (format t "waitqueue wakeup tests done~%") +;;; Make sure that a deadline handler is not invoked twice in a row in +;;; CONDITION-WAIT. See LP #512914 for a detailed explanation. +;;; +#-sb-lutex ; See KLUDGE above: no deadlines for condition-wait+lutexes. +(with-test (:name (:condition-wait :deadlines :LP-512914)) + (let ((n 2) ; was empirically enough to trigger the bug + (mutex (sb-thread:make-mutex)) + (waitq (sb-thread:make-waitqueue)) + (threads nil) + (deadline-handler-run-twice? nil)) + (dotimes (i n) + (let ((child + (sb-thread:make-thread + #'(lambda () + (handler-bind + ((sb-sys:deadline-timeout + (let ((already? nil)) + #'(lambda (c) + (when already? + (setq deadline-handler-run-twice? t)) + (setq already? t) + (sleep 0.2) + (sb-thread:condition-broadcast waitq) + (sb-sys:defer-deadline 10.0 c))))) + (sb-sys:with-deadline (:seconds 0.1) + (sb-thread:with-mutex (mutex) + (sb-thread:condition-wait waitq mutex)))))))) + (push child threads))) + (mapc #'sb-thread:join-thread threads) + (assert (not deadline-handler-run-twice?)))) + +(with-test (:name (:condition-wait :signal-deadline-with-interrupts-enabled)) + (let ((mutex (sb-thread:make-mutex)) + (waitq (sb-thread:make-waitqueue)) + (A-holds? :unknown) + (B-holds? :unknown) + (A-interrupts-enabled? :unknown) + (B-interrupts-enabled? :unknown) + (A) + (B)) + ;; W.L.O.G., we assume that A is executed first... + (setq A (sb-thread:make-thread + #'(lambda () + (handler-bind + ((sb-sys:deadline-timeout + #'(lambda (c) + ;; We came here through the call to DECODE-TIMEOUT + ;; in CONDITION-WAIT; hence both here are supposed + ;; to evaluate to T. + (setq A-holds? (sb-thread:holding-mutex-p mutex)) + (setq A-interrupts-enabled? + sb-sys:*interrupts-enabled*) + (sleep 0.2) + (sb-thread:condition-broadcast waitq) + (sb-sys:defer-deadline 10.0 c)))) + (sb-sys:with-deadline (:seconds 0.1) + (sb-thread:with-mutex (mutex) + (sb-thread:condition-wait waitq mutex))))))) + (setq B (sb-thread:make-thread + #'(lambda () + (thread-yield) + (handler-bind + ((sb-sys:deadline-timeout + #'(lambda (c) + ;; We came here through the call to GET-MUTEX + ;; in CONDITION-WAIT (contended case of + ;; reaquiring the mutex) - so the former will + ;; be NIL, but interrupts should still be enabled. + (setq B-holds? (sb-thread:holding-mutex-p mutex)) + (setq B-interrupts-enabled? + sb-sys:*interrupts-enabled*) + (sleep 0.2) + (sb-thread:condition-broadcast waitq) + (sb-sys:defer-deadline 10.0 c)))) + (sb-sys:with-deadline (:seconds 0.1) + (sb-thread:with-mutex (mutex) + (sb-thread:condition-wait waitq mutex))))))) + (sb-thread:join-thread A) + (sb-thread:join-thread B) + (let ((A-result (list A-holds? A-interrupts-enabled?)) + (B-result (list B-holds? B-interrupts-enabled?))) + ;; We also check some subtle behaviour w.r.t. whether a deadline + ;; handler in CONDITION-WAIT got the mutex, or not. This is most + ;; probably very internal behaviour (so user should not depend + ;; on it) -- I added the testing here just to manifest current + ;; behaviour. + (cond ((equal A-result '(t t)) (assert (equal B-result '(nil t)))) + ((equal B-result '(t t)) (assert (equal A-result '(nil t)))) + (t (error "Failure: fall through.")))))) + (with-test (:name (:mutex :finalization)) (let ((a nil)) (dotimes (i 500000)