+
+;;;; BLACK BOX TESTS
+
+(in-package :cl-user)
+(use-package :test-util)
+(use-package "ASSERTOID")
+
+(format t "parallel defclass test -- WARNING, WILL HANG ON FAILURE!~%")
+(with-test (:name :parallel-defclass)
+ (defclass test-1 () ((a :initform :orig-a)))
+ (defclass test-2 () ((b :initform :orig-b)))
+ (defclass test-3 (test-1 test-2) ((c :initform :orig-c)))
+ (let* ((run t)
+ (d1 (sb-thread:make-thread (lambda ()
+ (loop while run
+ do (defclass test-1 () ((a :initform :new-a)))
+ (write-char #\1)
+ (force-output)))
+ :name "d1"))
+ (d2 (sb-thread:make-thread (lambda ()
+ (loop while run
+ do (defclass test-2 () ((b :initform :new-b)))
+ (write-char #\2)
+ (force-output)))
+ :name "d2"))
+ (d3 (sb-thread:make-thread (lambda ()
+ (loop while run
+ do (defclass test-3 (test-1 test-2) ((c :initform :new-c)))
+ (write-char #\3)
+ (force-output)))
+ :name "d3"))
+ (i (sb-thread:make-thread (lambda ()
+ (loop while run
+ do (let ((i (make-instance 'test-3)))
+ (assert (member (slot-value i 'a) '(:orig-a :new-a)))
+ (assert (member (slot-value i 'b) '(:orig-b :new-b)))
+ (assert (member (slot-value i 'c) '(:orig-c :new-c))))
+ (write-char #\i)
+ (force-output)))
+ :name "i")))
+ (format t "~%sleeping!~%")
+ (sleep 2.0)
+ (format t "~%stopping!~%")
+ (setf run nil)
+ (mapc (lambda (th)
+ (sb-thread:join-thread th)
+ (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-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)
+ (sb-thread:wait-on-semaphore t1-can-go)
+ :ok1))
+ :name "T1"))
+ (t2 (sb-thread:make-thread
+ (lambda ()
+ (sb-ext:wait-for (eq t1 (sb-thread:mutex-owner m1)))
+ (sb-thread:with-mutex (m1 :wait-p t)
+ (sb-thread:wait-on-semaphore t2-can-go)
+ :ok2))
+ :name "T2")))
+ (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)
+ (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)
+ (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 '(:ok1 :ok2) 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)))))
+
+(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))))))))