(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))
;;;; 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
(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))
(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
;;; 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))
(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
(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)
(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))))))))
projects / sbcl.git / blobdiff