(with-test (:name (:grab-mutex :timeout :acquisition-fail))
#+sb-lutex
(error "Mutex timeout not supported here.")
- (let ((m (make-mutex)))
+ (let ((m (make-mutex))
+ (w (make-semaphore)))
(with-mutex (m)
- (assert (null (join-thread (make-thread
- #'(lambda ()
- (grab-mutex m :timeout 0.1)))))))))
+ (let ((th (make-thread
+ #'(lambda ()
+ (prog1
+ (grab-mutex m :timeout 0.1)
+ (signal-semaphore w))))))
+ ;; Wait for it to -- otherwise the detect the deadlock chain
+ ;; from JOIN-THREAD.
+ (wait-on-semaphore w)
+ (assert (null (join-thread th)))))))
(with-test (:name (:grab-mutex :timeout :acquisition-success))
#+sb-lutex
(with-test (:name (:grab-mutex :timeout+deadline))
#+sb-lutex
(error "Mutex timeout not supported here.")
- (let ((m (make-mutex)))
+ (let ((m (make-mutex))
+ (w (make-semaphore)))
(with-mutex (m)
- (assert (eq (join-thread
- (make-thread #'(lambda ()
- (sb-sys:with-deadline (:seconds 0.0)
- (handler-case
- (grab-mutex m :timeout 0.0)
- (sb-sys:deadline-timeout ()
- :deadline))))))
- :deadline)))))
+ (let ((th (make-thread #'(lambda ()
+ (sb-sys:with-deadline (:seconds 0.0)
+ (handler-case
+ (grab-mutex m :timeout 0.0)
+ (sb-sys:deadline-timeout ()
+ (signal-semaphore w)
+ :deadline)))))))
+ (wait-on-semaphore w)
+ (assert (eq (join-thread th) :deadline))))))
(with-test (:name (:grab-mutex :waitp+deadline))
#+sb-lutex
(defun alloc-stuff () (copy-list '(1 2 3 4 5)))
(with-test (:name (:interrupt-thread :interrupt-consing-child))
- #+darwin
- (error "Hangs on Darwin.")
(let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff))))))
(let ((killers
(loop repeat 4 collect
#+(or x86 x86-64) ;; x86oid-only, see internal commentary.
(with-test (:name (:interrupt-thread :interrupt-consing-child :again))
- #+darwin
- (error "Hangs on Darwin.")
(let ((c (make-thread (lambda () (loop (alloc-stuff))))))
;; NB this only works on x86: other ports don't have a symbol for
;; pseudo-atomic atomicity
(assert (sb-thread:join-thread thread))))
(with-test (:name (:two-threads-running-gc))
- #+darwin
- (error "Hangs on Darwin.")
(let (a-done b-done)
(make-thread (lambda ()
(dotimes (i 100)
(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.
(format t "~&multiple reader hash table test done~%")
(with-test (:name (:hash-table-single-accessor-parallel-gc))
- #+darwin
- (error "Prone to hang on Darwin due to interrupt issues.")
(let ((hash (make-hash-table))
(*errors* nil))
(let ((threads (list (sb-thread:make-thread
(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)))))