(wait-on-semaphore sem)
(assert signalled-p)))
-(with-test (:name (:semaphore :multiple-signals))
+(defun test-semaphore-multiple-signals (wait-on-semaphore)
(let* ((sem (make-semaphore :count 5))
- (threads (loop repeat 20
- collect (make-thread (lambda ()
- (wait-on-semaphore sem))))))
+ (threads (loop repeat 20 collecting
+ (make-thread (lambda ()
+ (funcall wait-on-semaphore sem))))))
(flet ((count-live-threads ()
(count-if #'thread-alive-p threads)))
(sleep 0.5)
(sleep 0.5)
(assert (= 0 (count-live-threads))))))
+(with-test (:name (:semaphore :multiple-signals))
+ (test-semaphore-multiple-signals #'wait-on-semaphore))
+
+(with-test (:name (:try-semaphore :trivial-fail))
+ (assert (eq (try-semaphore (make-semaphore :count 0)) 'nil)))
+
+(with-test (:name (:try-semaphore :trivial-success))
+ (let ((sem (make-semaphore :count 1)))
+ (assert (try-semaphore sem))
+ (assert (zerop (semaphore-count sem)))))
+
+(with-test (:name (:try-semaphore :emulate-wait-on-semaphore))
+ (flet ((busy-wait-on-semaphore (sem)
+ (loop until (try-semaphore sem) do (sleep 0.001))))
+ (test-semaphore-multiple-signals #'busy-wait-on-semaphore)))
+
+;;; Here we test that interrupting TRY-SEMAPHORE does not leave a
+;;; semaphore in a bad state.
+(with-test (:name (:try-semaphore :interrupt-safe))
+ (flet ((make-threads (count fn)
+ (loop repeat count collect (make-thread fn)))
+ (kill-thread (thread)
+ (when (thread-alive-p thread)
+ (ignore-errors (terminate-thread thread))))
+ (count-live-threads (threads)
+ (count-if #'thread-alive-p threads)))
+ ;; WAITERS will already be waiting on the semaphore while
+ ;; threads-being-interrupted will perform TRY-SEMAPHORE on that
+ ;; semaphore, and MORE-WAITERS are new threads trying to wait on
+ ;; the semaphore during the interruption-fire.
+ (let* ((sem (make-semaphore :count 50))
+ (waiters (make-threads 20 #'(lambda ()
+ (wait-on-semaphore sem))))
+ (triers (make-threads 40 #'(lambda ()
+ (sleep (random 0.01))
+ (try-semaphore sem))))
+ (more-waiters
+ (loop repeat 10
+ do (kill-thread (nth (random 40) triers))
+ collect (make-thread #'(lambda () (wait-on-semaphore sem)))
+ do (kill-thread (nth (random 40) triers)))))
+ (sleep 0.5)
+ ;; Now ensure that the waiting threads will all be waked up,
+ ;; i.e. that the semaphore is still working.
+ (loop repeat (+ (count-live-threads waiters)
+ (count-live-threads more-waiters))
+ do (signal-semaphore sem))
+ (sleep 0.5)
+ (assert (zerop (count-live-threads triers)))
+ (assert (zerop (count-live-threads waiters)))
+ (assert (zerop (count-live-threads more-waiters))))))
+
+
+
(format t "~&semaphore tests done~%")
(defun test-interrupt (function-to-interrupt &optional quit-p)
(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)
(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))))
(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)
projects / sbcl.git / blobdiff