(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))
(grab-mutex m :waitp nil)))))))))
(with-test (:name (:grab-mutex :timeout :acquisition-fail))
- #+sb-lutex
- (error "Mutex timeout not supported here.")
(let ((m (make-mutex))
(w (make-semaphore)))
(with-mutex (m)
(assert (null (join-thread th)))))))
(with-test (:name (:grab-mutex :timeout :acquisition-success))
- #+sb-lutex
- (error "Mutex timeout not supported here.")
(let ((m (make-mutex))
(child))
(with-mutex (m)
(assert (eq (join-thread child) 't))))
(with-test (:name (:grab-mutex :timeout+deadline))
- #+sb-lutex
- (error "Mutex timeout not supported here.")
(let ((m (make-mutex))
(w (make-semaphore)))
(with-mutex (m)
(assert (eq (join-thread th) :deadline))))))
(with-test (:name (:grab-mutex :waitp+deadline))
- #+sb-lutex
- (error "Mutex timeout not supported here.")
(let ((m (make-mutex)))
(with-mutex (m)
(assert (eq (join-thread
(defun alloc-stuff () (copy-list '(1 2 3 4 5)))
-(with-test (:name (:interrupt-thread :interrupt-consing-child))
+(with-test (:name (:interrupt-thread :interrupt-consing-child)
+ :broken-on :darwin)
(let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff))))))
(let ((killers
(loop repeat 4 collect
;; now SOMETHING is gc'ed and the binding stack looks like this: 0,
;; 0, SOMETHING, 0 (because the symbol slots are zeroed on
;; unbinding but values are not).
- (let ((*x* nil))
+ (let ((*x* nil)
+ (binding-pointer-delta (ash 2 (- sb-vm:word-shift sb-vm:n-fixnum-tag-bits))))
;; bump bsp as if a BIND had just started
- (incf sb-vm::*binding-stack-pointer* 2)
+ (incf sb-vm::*binding-stack-pointer* binding-pointer-delta)
(wait-for-gc)
- (decf sb-vm::*binding-stack-pointer* 2))))
+ (decf sb-vm::*binding-stack-pointer* binding-pointer-delta))))
(with-test (:name (:binding-stack-gc-safety))
(let (threads)
(sb-debug:backtrace)
(catch 'done))
-(with-test (:name (:unsynchronized-hash-table))
+(with-test (:name (:unsynchronized-hash-table)
+ ;; FIXME: This test occasionally eats out craploads
+ ;; of heap instead of expected error early. Not 100%
+ ;; sure if it would finish as expected, but since it
+ ;; hits swap on my system I'm not likely to find out
+ ;; soon. Disabling for now. -- nikodemus
+ :skipped-on :sbcl)
;; We expect a (probable) error here: parellel readers and writers
;; on a hash-table are not expected to work -- but we also don't
;; expect this to corrupt the image.
;;; 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
+(with-test (:name (:condition-wait :deadlines :LP-512914)
+ :skipped-on '(not :sb-futex))
+ (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))))))))
+ (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))
- #+darwin
- (error "Bad Darwin")
(let ((mutex (sb-thread:make-mutex))
(waitq (sb-thread:make-waitqueue))
(A-holds? :unknown)
(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:condition-wait waitq mutex)))))
+ :name "A"))
(setq B (sb-thread:make-thread
#'(lambda ()
(thread-yield)
(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:condition-wait waitq mutex)))))
+ :name "B"))
(sb-thread:join-thread A)
(sb-thread:join-thread B)
(let ((A-result (list A-holds? A-interrupts-enabled?))
;; 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."))))))
+ (t
+ (error "Failure: fell through wit A: ~S, B: ~S"
+ A-result
+ B-result))))))
(with-test (:name (:mutex :finalization))
(let ((a nil))
(format t "infodb test done~%")
-(with-test (:name (:backtrace))
- #+darwin
- (error "Prone to crash on Darwin, cause unknown.")
+(with-test (:name :backtrace)
;; Printing backtraces from several threads at once used to hang the
;; whole SBCL process (discovered by accident due to a timer.impure
;; test misbehaving). The cause was that packages weren't even
(format t "~&starting gc deadlock test: WARNING: THIS TEST WILL HANG ON FAILURE!~%")
-(with-test (:name (:gc-deadlock))
- #+darwin
- (error "Prone to hang on Darwin due to interrupt issues.")
+(with-test (:name :gc-deadlock
+ ;; Prone to hang on Darwin due to interrupt issues.
+ :broken-on :darwin)
;; 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
(format t "~%joined ~S~%" (sb-thread:thread-name th)))
(list d1 d2 d3 i))))
(format t "parallel defclass test done~%")
+
+(with-test (:name (:deadlock-detection :interrupts))
+ (let* ((m1 (sb-thread:make-mutex :name "M1"))
+ (m2 (sb-thread:make-mutex :name "M2"))
+ (t1 (sb-thread:make-thread
+ (lambda ()
+ (sb-thread:with-mutex (m1)
+ (sleep 0.3)
+ :ok))
+ :name "T1"))
+ (t2 (sb-thread:make-thread
+ (lambda ()
+ (sleep 0.1)
+ (sb-thread:with-mutex (m1 :wait-p t)
+ (sleep 0.2)
+ :ok))
+ :name "T2")))
+ (sleep 0.2)
+ (sb-thread:interrupt-thread t2 (lambda ()
+ (sb-thread:with-mutex (m2 :wait-p t)
+ (sleep 0.3))))
+ (sleep 0.05)
+ (sb-thread:interrupt-thread t1 (lambda ()
+ (sb-thread:with-mutex (m2 :wait-p t)
+ (sleep 0.3))))
+ ;; 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)))))
+
+(with-test (:name (:deadlock-detection :gc))
+ ;; To semi-reliably trigger the error (in SBCL's where)
+ ;; it was present you had to run this for > 30 seconds,
+ ;; but that's a bit long for a single test.
+ (let* ((stop (+ 5 (get-universal-time)))
+ (m1 (sb-thread:make-mutex :name "m1"))
+ (t1 (sb-thread:make-thread
+ (lambda ()
+ (loop until (> (get-universal-time) stop)
+ do (sb-thread:with-mutex (m1)
+ (eval `(make-array 24))))
+ :ok)))
+ (t2 (sb-thread:make-thread
+ (lambda ()
+ (loop until (> (get-universal-time) stop)
+ do (sb-thread:with-mutex (m1)
+ (eval `(make-array 24))))
+ :ok))))
+ (let ((res (list (sb-thread:join-thread t1)
+ (sb-thread:join-thread t2))))
+ (assert (equal '(:ok :ok) res)))))
projects / sbcl.git / blobdiff