X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=tests%2Fthreads.impure.lisp;h=546ce5c95f98699048d41d718003b614fafa4a05;hb=6e5c24e786277417fedfea9a6844092de11775df;hp=9672f49ee951644d02672fa50209bbf8074aed3b;hpb=d6f9676ae94419cb5544c45821a8d31adbc1fbe8;p=sbcl.git diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 9672f49..546ce5c 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -37,10 +37,6 @@ (with-mutex (mutex) mutex))) -(with-test (:name (:with-spinlock :basics)) - (let ((spinlock (make-spinlock))) - (with-spinlock (spinlock)))) - (sb-alien:define-alien-routine "check_deferrables_blocked_or_lose" void (where sb-alien:unsigned-long)) @@ -76,19 +72,19 @@ ;;;; Now the real tests... -(with-test (:name (:interrupt-thread :deferrables-unblocked-by-spinlock)) - (let ((spinlock (sb-thread::make-spinlock)) +(with-test (:name (:interrupt-thread :deferrables-unblocked-by-lock)) + (let ((lock (sb-thread::make-mutex)) (thread (sb-thread:make-thread (lambda () (loop (sleep 1)))))) - (sb-thread::get-spinlock spinlock) + (sb-thread::grab-mutex lock) (sb-thread:interrupt-thread thread (lambda () (check-deferrables-blocked-or-lose 0) - (sb-thread::get-spinlock spinlock) + (sb-thread::grab-mutex lock) (check-deferrables-unblocked-or-lose 0) (sb-ext:quit))) (sleep 1) - (sb-thread::release-spinlock spinlock))) + (sb-thread::release-mutex lock))) ;;; compare-and-swap @@ -229,38 +225,11 @@ (assert (ours-p (mutex-value l)) nil "5")) (assert (eql (mutex-value l) nil) nil "6")))) -(with-test (:name (:with-recursive-spinlock :basics)) - (labels ((ours-p (value) - (eq *current-thread* value))) - (let ((l (make-spinlock :name "rec"))) - (assert (eql (spinlock-value l) nil) nil "1") - (with-recursive-spinlock (l) - (assert (ours-p (spinlock-value l)) nil "3") - (with-recursive-spinlock (l) - (assert (ours-p (spinlock-value l)) nil "4")) - (assert (ours-p (spinlock-value l)) nil "5")) - (assert (eql (spinlock-value l) nil) nil "6")))) - (with-test (:name (:mutex :nesting-mutex-and-recursive-lock)) (let ((l (make-mutex :name "a mutex"))) (with-mutex (l) (with-recursive-lock (l))))) -(with-test (:name (:spinlock :nesting-spinlock-and-recursive-spinlock)) - (let ((l (make-spinlock :name "a spinlock"))) - (with-spinlock (l) - (with-recursive-spinlock (l))))) - -(with-test (:name (:spinlock :more-basics)) - (let ((l (make-spinlock :name "spinlock"))) - (assert (eql (spinlock-value l) nil) ((spinlock-value l)) - "spinlock not free (1)") - (with-spinlock (l) - (assert (eql (spinlock-value l) *current-thread*) ((spinlock-value l)) - "spinlock not taken")) - (assert (eql (spinlock-value l) nil) ((spinlock-value l)) - "spinlock not free (2)"))) - ;; test that SLEEP actually sleeps for at least the given time, even ;; if interrupted by another thread exiting/a gc/anything (with-test (:name (:sleep :continue-sleeping-after-interrupt)) @@ -559,8 +528,7 @@ (defun alloc-stuff () (copy-list '(1 2 3 4 5))) -(with-test (:name (:interrupt-thread :interrupt-consing-child) - :broken-on :darwin) +(with-test (:name (:interrupt-thread :interrupt-consing-child)) (let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff)))))) (let ((killers (loop repeat 4 collect @@ -1073,8 +1041,7 @@ ;;; Make sure that a deadline handler is not invoked twice in a row in ;;; CONDITION-WAIT. See LP #512914 for a detailed explanation. ;;; -(with-test (:name (:condition-wait :deadlines :LP-512914) - :skipped-on '(not :sb-futex)) +(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)) @@ -1224,9 +1191,7 @@ (format t "~&starting gc deadlock test: WARNING: THIS TEST WILL HANG ON FAILURE!~%") -(with-test (:name :gc-deadlock - ;; Prone to hang on Darwin due to interrupt issues. - :broken-on :darwin) +(with-test (:name :gc-deadlock) ;; Prior to 0.9.16.46 thread exit potentially deadlocked the ;; GC due to *all-threads-lock* and session lock. On earlier ;; versions and at least on one specific box this test is good enough @@ -1390,32 +1355,36 @@ (with-test (:name (:deadlock-detection :interrupts)) (let* ((m1 (sb-thread:make-mutex :name "M1")) (m2 (sb-thread:make-mutex :name "M2")) + (t1-can-go (sb-thread:make-semaphore :name "T1 can go")) + (t2-can-go (sb-thread:make-semaphore :name "T2 can go")) (t1 (sb-thread:make-thread (lambda () (sb-thread:with-mutex (m1) - (sleep 0.3) - :ok)) + (sb-thread:wait-on-semaphore t1-can-go) + :ok1)) :name "T1")) (t2 (sb-thread:make-thread (lambda () - (sleep 0.1) + (sb-ext:wait-for (eq t1 (sb-thread:mutex-owner m1))) (sb-thread:with-mutex (m1 :wait-p t) - (sleep 0.2) - :ok)) + (sb-thread:wait-on-semaphore t2-can-go) + :ok2)) :name "T2"))) - (sleep 0.2) + (sb-ext:wait-for (eq m1 (sb-thread::thread-waiting-for t2))) (sb-thread:interrupt-thread t2 (lambda () (sb-thread:with-mutex (m2 :wait-p t) - (sleep 0.3)))) - (sleep 0.05) + (sb-ext:wait-for + (eq m2 (sb-thread::thread-waiting-for t1))) + (sb-thread:signal-semaphore t2-can-go)))) + (sb-ext:wait-for (eq t2 (sb-thread:mutex-owner m2))) (sb-thread:interrupt-thread t1 (lambda () (sb-thread:with-mutex (m2 :wait-p t) - (sleep 0.3)))) + (sb-thread:signal-semaphore t1-can-go)))) ;; both threads should finish without a deadlock or deadlock ;; detection error (let ((res (list (sb-thread:join-thread t1) (sb-thread:join-thread t2)))) - (assert (equal '(:ok :ok) res))))) + (assert (equal '(:ok1 :ok2) res))))) (with-test (:name (:deadlock-detection :gc)) ;; To semi-reliably trigger the error (in SBCL's where) @@ -1438,3 +1407,26 @@ (let ((res (list (sb-thread:join-thread t1) (sb-thread:join-thread t2)))) (assert (equal '(:ok :ok) res))))) + +(with-test (:name :spinlock-api) + (let* ((warned 0) + (funs + (handler-bind ((sb-int:early-deprecation-warning (lambda (_) + (declare (ignore _)) + (incf warned)))) + (list (compile nil `(lambda (lock) + (sb-thread::with-spinlock (lock) + t))) + (compile nil `(lambda () + (sb-thread::make-spinlock :name "foo"))) + (compile nil `(lambda (lock) + (sb-thread::get-spinlock lock))) + (compile nil `(lambda (lock) + (sb-thread::release-spinlock lock))))))) + (assert (eql 4 warned)) + (handler-bind ((warning #'error)) + (destructuring-bind (with make get release) funs + (let ((lock (funcall make))) + (funcall get lock) + (funcall release lock) + (assert (eq t (funcall with lock))))))))