X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=tests%2Fthreads.pure.lisp;h=1b2ea7f31aa5709faed1d0a293e09c092c54f0f4;hb=HEAD;hp=00040dd37130908b8c1144397b3f3a186c63af59;hpb=b8846766dd1ecb2b6c3dce848f2aae0b3b11a6ea;p=sbcl.git diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp index 00040dd..1b2ea7f 100644 --- a/tests/threads.pure.lisp +++ b/tests/threads.pure.lisp @@ -55,7 +55,7 @@ ;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS -(with-test (:name without-interrupts+condition-wait +(with-test (:name :without-interrupts+condition-wait :skipped-on '(not :sb-thread) :fails-on '(and :win32 :sb-futex)) (let* ((lock (make-mutex)) @@ -75,7 +75,7 @@ ;;; GRAB-MUTEX should not be interruptible under WITHOUT-INTERRUPTS -(with-test (:name without-interrupts+grab-mutex :skipped-on '(not :sb-thread)) +(with-test (:name :without-interrupts+grab-mutex :skipped-on '(not :sb-thread)) (let* ((lock (make-mutex)) (bar (progn (grab-mutex lock) nil)) (thread (make-thread (lambda () @@ -93,7 +93,7 @@ (assert (eq :aborted (join-thread thread :default :aborted))) (assert bar))) -(with-test (:name parallel-find-class :skipped-on '(not :sb-thread)) +(with-test (:name :parallel-find-class :skipped-on '(not :sb-thread)) (let* ((oops nil) (threads (loop repeat 10 collect (make-thread (lambda () @@ -171,14 +171,14 @@ ;;;; SYMBOL-VALUE-IN-THREAD -(with-test (:name symbol-value-in-thread.1) +(with-test (:name :symbol-value-in-thread.1) (let ((* (cons t t))) (assert (eq * (symbol-value-in-thread '* *current-thread*))) (setf (symbol-value-in-thread '* *current-thread*) 123) (assert (= 123 (symbol-value-in-thread '* *current-thread*))) (assert (= 123 *)))) -(with-test (:name symbol-value-in-thread.2 :skipped-on '(not :sb-thread)) +(with-test (:name :symbol-value-in-thread.2 :skipped-on '(not :sb-thread)) (let* ((parent *current-thread*) (semaphore (make-semaphore)) (child (make-thread (lambda () @@ -194,7 +194,7 @@ ;;; Disabled on Darwin due to deadlocks caused by apparent OS specific deadlocks, ;;; wich _appear_ to be caused by malloc() and free() not being thread safe: an ;;; interrupted malloc in one thread can apparently block a free in another. -(with-test (:name symbol-value-in-thread.3 +(with-test (:name :symbol-value-in-thread.3 :skipped-on '(not :sb-thread)) (let* ((parent *current-thread*) (semaphore (make-semaphore)) @@ -228,7 +228,7 @@ (setf running nil) (join-thread noise))) -(with-test (:name symbol-value-in-thread.4 :skipped-on '(not :sb-thread)) +(with-test (:name :symbol-value-in-thread.4 :skipped-on '(not :sb-thread)) (let* ((parent *current-thread*) (semaphore (make-semaphore)) (child (make-thread (lambda () @@ -237,7 +237,7 @@ (signal-semaphore semaphore) (assert (equal '(nil nil) (multiple-value-list (join-thread child)))))) -(with-test (:name symbol-value-in-thread.5 :skipped-on '(not :sb-thread)) +(with-test (:name :symbol-value-in-thread.5 :skipped-on '(not :sb-thread)) (let* ((parent *current-thread*) (semaphore (make-semaphore)) (child (make-thread (lambda () @@ -252,7 +252,7 @@ (assert (equal (list *current-thread* 'this-is-new (list :read :unbound-in-thread)) (join-thread child))))) -(with-test (:name symbol-value-in-thread.6 :skipped-on '(not :sb-thread)) +(with-test (:name :symbol-value-in-thread.6 :skipped-on '(not :sb-thread)) (let* ((parent *current-thread*) (semaphore (make-semaphore)) (name (gensym)) @@ -270,7 +270,7 @@ (unless (equal res want) (error "wanted ~S, got ~S" want res))))) -(with-test (:name symbol-value-in-thread.7 :skipped-on '(not :sb-thread)) +(with-test (:name :symbol-value-in-thread.7 :skipped-on '(not :sb-thread)) (let ((child (make-thread (lambda ()))) (error-occurred nil)) (join-thread child) @@ -284,7 +284,7 @@ (sb-thread::symbol-value-in-thread-error-info e))))) (assert error-occurred))) -(with-test (:name symbol-value-in-thread.8 :skipped-on '(not :sb-thread)) +(with-test (:name :symbol-value-in-thread.8 :skipped-on '(not :sb-thread)) (let ((child (make-thread (lambda ()))) (error-occurred nil)) (join-thread child) @@ -298,7 +298,7 @@ (sb-thread::symbol-value-in-thread-error-info e))))) (assert error-occurred))) -(with-test (:name deadlock-detection.1 :skipped-on '(not :sb-thread)) +(with-test (:name :deadlock-detection.1 :skipped-on '(not :sb-thread)) (loop repeat 1000 do (flet ((test (ma mb sa sb) @@ -324,7 +324,7 @@ (assert (or (equal '(:deadlock :ok) res) (equal '(:ok :deadlock) res)))))))) -(with-test (:name deadlock-detection.2 :skipped-on '(not :sb-thread)) +(with-test (:name :deadlock-detection.2 :skipped-on '(not :sb-thread)) (let* ((m1 (sb-thread:make-mutex :name "M1")) (m2 (sb-thread:make-mutex :name "M2")) (s1 (sb-thread:make-semaphore :name "S1")) @@ -359,7 +359,7 @@ (assert (stringp err))) (assert (eq :ok (sb-thread:join-thread t1))))) -(with-test (:name deadlock-detection.3 :skipped-on '(not :sb-thread)) +(with-test (:name :deadlock-detection.3 :skipped-on '(not :sb-thread)) (let* ((m1 (sb-thread:make-mutex :name "M1")) (m2 (sb-thread:make-mutex :name "M2")) (s1 (sb-thread:make-semaphore :name "S1")) @@ -505,6 +505,54 @@ :timeout 0.01 :default cookie))))) +(with-test (:name (:semaphore-notification :wait-on-semaphore :lp-1038034) + :skipped-on '(not :sb-thread) + :fails-on :sb-thread) + ;; Test robustness of semaphore acquisition and notification with + ;; asynchronous thread termination... Which we know is currently + ;; fragile. + (dotimes (run 180) + (let ((sem (make-semaphore))) + ;; In CRITICAL, WAIT-ON-SEMAPHORE and SLEEP can be interrupted + ;; by TERMINATE-THREAD below. But the SIGNAL-SEMAPHORE cleanup + ;; cannot be interrupted. + (flet ((critical (sleep) + (let ((note (make-semaphore-notification))) + (sb-sys:without-interrupts + (unwind-protect + (sb-sys:with-local-interrupts + (wait-on-semaphore sem :notification note) + (sleep sleep)) + ;; Re-increment on exit if we decremented it. + (when (semaphore-notification-status note) + (signal-semaphore sem))))))) + ;; Create /parallel/ threads trying to acquire and then signal + ;; the semaphore. Try to asynchronously abort T2 just as T1 is + ;; exiting. + (destructuring-bind (t1 t2 t3) + (loop for i from 1 + for sleep in '(0.01 0.02 0.02) + collect (make-thread #'critical :arguments sleep + :name (format nil "T~A" i))) + (signal-semaphore sem) + (sleep 0.01) + (ignore-errors + (terminate-thread t2)) + (flet ((safe-join-thread (thread &key timeout) + (assert timeout) + (when (eq :timeout + (join-thread thread + :timeout timeout + :default :timeout)) + (error "Hang in (join-thread ~A) ?" thread)))) + (safe-join-thread t1 :timeout 10) + (safe-join-thread t3 :timeout 10))))) + (when (zerop (mod run 60)) + (fresh-line) + (write-string "; ")) + (write-char #\.) + (force-output))) + (with-test (:name (:semaphore-notification :wait-on-semaphore) :skipped-on '(not :sb-thread)) (let ((sem (make-semaphore))