+(with-test (:name (:condition-variable :notify-multiple))
+ (flet ((tester (notify-fun)
+ (let ((queue (make-waitqueue :name "queue"))
+ (lock (make-mutex :name "lock"))
+ (data nil))
+ (labels ((test (x)
+ (loop
+ (with-mutex (lock)
+ (format t "condition-wait ~a~%" x)
+ (force-output)
+ (condition-wait queue lock)
+ (format t "woke up ~a~%" x)
+ (force-output)
+ (push x data)))))
+ (let ((threads (loop for x from 1 to 10
+ collect
+ (let ((x x))
+ (make-kill-thread (lambda ()
+ (test x)))))))
+ (sleep 5)
+ (with-mutex (lock)
+ (funcall notify-fun queue))
+ (sleep 5)
+ (mapcar #'terminate-thread threads)
+ ;; Check that all threads woke up at least once
+ (assert (= (length (remove-duplicates data)) 10)))))))
+ (tester (lambda (queue)
+ (format t "~&(condition-notify queue 10)~%")
+ (force-output)
+ (condition-notify queue 10)))
+ (tester (lambda (queue)
+ (format t "~&(condition-broadcast queue)~%")
+ (force-output)
+ (condition-broadcast queue)))))
+
+(format t "waitqueue wakeup tests done~%")
+
+;;; 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))
+ (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))))))))
+ (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))
+ (let ((mutex (sb-thread:make-mutex))
+ (waitq (sb-thread:make-waitqueue))
+ (A-holds? :unknown)
+ (B-holds? :unknown)
+ (A-interrupts-enabled? :unknown)
+ (B-interrupts-enabled? :unknown)
+ (A)
+ (B))
+ ;; W.L.O.G., we assume that A is executed first...
+ (setq A (sb-thread:make-thread
+ #'(lambda ()
+ (handler-bind
+ ((sb-sys:deadline-timeout
+ #'(lambda (c)
+ ;; We came here through the call to DECODE-TIMEOUT
+ ;; in CONDITION-WAIT; hence both here are supposed
+ ;; to evaluate to T.
+ (setq A-holds? (sb-thread:holding-mutex-p mutex))
+ (setq A-interrupts-enabled?
+ sb-sys:*interrupts-enabled*)
+ (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)))))
+ :name "A"))
+ (setq B (sb-thread:make-thread
+ #'(lambda ()
+ (thread-yield)
+ (handler-bind
+ ((sb-sys:deadline-timeout
+ #'(lambda (c)
+ ;; We came here through the call to DECODE-TIMEOUT
+ ;; in CONDITION-WAIT (contended case of
+ ;; reaquiring the mutex) - so the former will
+ ;; be NIL, but interrupts should still be enabled.
+ (setq B-holds? (sb-thread:holding-mutex-p mutex))
+ (setq B-interrupts-enabled?
+ sb-sys:*interrupts-enabled*)
+ (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)))))
+ :name "B"))
+ (sb-thread:join-thread A)
+ (sb-thread:join-thread B)
+ (let ((A-result (list A-holds? A-interrupts-enabled?))
+ (B-result (list B-holds? B-interrupts-enabled?)))
+ ;; We also check some subtle behaviour w.r.t. whether a deadline
+ ;; handler in CONDITION-WAIT got the mutex, or not. This is most
+ ;; probably very internal behaviour (so user should not depend
+ ;; on it) -- I added the testing here just to manifest current
+ ;; 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: fell through wit A: ~S, B: ~S"
+ A-result
+ B-result))))))
+
+(with-test (:name (:mutex :finalization))
+ (let ((a nil))
+ (dotimes (i 500000)
+ (setf a (make-mutex)))))
+
+(format t "mutex finalization test done~%")
+
+;;; Check that INFO is thread-safe, at least when we're just doing reads.
+
+(let* ((symbols (loop repeat 10000 collect (gensym)))
+ (functions (loop for (symbol . rest) on symbols
+ for next = (car rest)
+ for fun = (let ((next next))
+ (lambda (n)
+ (if next
+ (funcall next (1- n))
+ n)))
+ do (setf (symbol-function symbol) fun)
+ collect fun)))
+ (defun infodb-test ()
+ (funcall (car functions) 9999)))
+
+(with-test (:name (:infodb :read))
+ (let* ((ok t)
+ (threads (loop for i from 0 to 10
+ collect (sb-thread:make-thread
+ (lambda ()
+ (dotimes (j 100)
+ (write-char #\-)
+ (finish-output)
+ (let ((n (infodb-test)))
+ (unless (zerop n)
+ (setf ok nil)
+ (format t "N != 0 (~A)~%" n)
+ (abort-thread)))))))))
+ (wait-for-threads threads)
+ (assert ok)))
+
+(format t "infodb test done~%")
+
+(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
+ ;; thread-safe for only doing FIND-SYMBOL, and while printing
+ ;; backtraces a loot of symbol lookups need to be done due to
+ ;; *PRINT-ESCAPE*.
+ (let* ((threads (loop repeat 10
+ collect (sb-thread:make-thread
+ (lambda ()
+ (dotimes (i 1000)
+ (with-output-to-string (*debug-io*)
+ (sb-debug::backtrace 10))))))))
+ (wait-for-threads threads)))
+
+(format t "backtrace test done~%")
+
+(format t "~&starting gc deadlock test: WARNING: THIS TEST WILL HANG ON FAILURE!~%")
+
+(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
+ ;; to catch that typically well before the 1500th iteration.
+ (loop
+ with i = 0
+ with n = 3000
+ while (< i n)
+ do
+ (incf i)
+ (when (zerop (mod i 100))
+ (write-char #\.)
+ (force-output))
+ (handler-case
+ (if (oddp i)
+ (make-join-thread
+ (lambda ()
+ (sleep (random 0.001)))
+ :name (format nil "SLEEP-~D" i))
+ (make-join-thread
+ (lambda ()
+ ;; KLUDGE: what we are doing here is explicit,
+ ;; but the same can happen because of a regular
+ ;; MAKE-THREAD or LIST-ALL-THREADS, and various
+ ;; session functions.
+ (sb-thread::with-all-threads-lock
+ (sb-thread::with-session-lock (sb-thread::*session*)
+ (sb-ext:gc))))
+ :name (format nil "GC-~D" i)))
+ (error (e)
+ (format t "~%error creating thread ~D: ~A -- backing off for retry~%" i e)
+ (sleep 0.1)
+ (incf i)))))
+
+(format t "~&gc deadlock test done~%")
+\f
+(let ((count (make-array 8 :initial-element 0)))
+ (defun closure-one ()
+ (declare (optimize safety))
+ (values (incf (aref count 0)) (incf (aref count 1))
+ (incf (aref count 2)) (incf (aref count 3))
+ (incf (aref count 4)) (incf (aref count 5))
+ (incf (aref count 6)) (incf (aref count 7))))
+ (defun no-optimizing-away-closure-one ()
+ (setf count (make-array 8 :initial-element 0))))
+
+(defstruct box
+ (count 0))
+
+(let ((one (make-box))
+ (two (make-box))
+ (three (make-box)))
+ (defun closure-two ()
+ (declare (optimize safety))
+ (values (incf (box-count one)) (incf (box-count two)) (incf (box-count three))))
+ (defun no-optimizing-away-closure-two ()
+ (setf one (make-box)
+ two (make-box)
+ three (make-box))))
+
+;;; PowerPC safepoint builds occasionally hang or busy-loop (or
+;;; sometimes run out of memory) in the following test. For developers
+;;; interested in debugging this combination of features, it might be
+;;; fruitful to concentrate their efforts around this test...
+
+(with-test (:name (:funcallable-instances)
+ :skipped-on '(and :sb-safepoint
+ (not :c-stack-is-control-stack)))
+ ;; the funcallable-instance implementation used not to be threadsafe
+ ;; against setting the funcallable-instance function to a closure
+ ;; (because the code and lexenv were set separately).
+ (let ((fun (sb-kernel:%make-funcallable-instance 0))
+ (condition nil))
+ (setf (sb-kernel:funcallable-instance-fun fun) #'closure-one)
+ (flet ((changer ()
+ (loop (setf (sb-kernel:funcallable-instance-fun fun) #'closure-one)
+ (setf (sb-kernel:funcallable-instance-fun fun) #'closure-two)))
+ (test ()
+ (handler-case (loop (funcall fun))
+ (serious-condition (c) (setf condition c)))))
+ (let ((changer (make-thread #'changer))
+ (test (make-thread #'test)))
+ (handler-case
+ (progn
+ ;; The two closures above are fairly carefully crafted
+ ;; so that if given the wrong lexenv they will tend to
+ ;; do some serious damage, but it is of course difficult
+ ;; to predict where the various bits and pieces will be
+ ;; allocated. Five seconds failed fairly reliably on
+ ;; both my x86 and x86-64 systems. -- CSR, 2006-09-27.
+ (sb-ext:with-timeout 5
+ (wait-for-threads (list test)))
+ (error "~@<test thread got condition:~2I~_~A~@:>" condition))
+ (sb-ext:timeout ()
+ (terminate-thread changer)
+ (terminate-thread test)
+ (wait-for-threads (list changer test))))))))
+
+(format t "~&funcallable-instance test done~%")
+
+(defun random-type (n)
+ `(integer ,(random n) ,(+ n (random n))))
+
+(defun subtypep-hash-cache-test ()
+ (dotimes (i 10000)
+ (let ((type1 (random-type 500))
+ (type2 (random-type 500)))
+ (let ((a (subtypep type1 type2)))
+ (dotimes (i 100)
+ (assert (eq (subtypep type1 type2) a))))))
+ (format t "ok~%")
+ (force-output))
+
+(with-test (:name (:hash-cache :subtypep))
+ (mapc #'join-thread
+ (loop repeat 10
+ collect (sb-thread:make-thread #'subtypep-hash-cache-test))))
+(format t "hash-cache tests done~%")
+
+;;;; 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)))
+ ;; This test is more likely to pass on Windows with the FORCE-OUTPUT
+ ;; calls disabled in the folloving code. (As seen on a Server 2012
+ ;; installation.) Clearly, this sort of workaround in a test is
+ ;; cheating, and might be hiding the underlying bug that the test is
+ ;; exposing. Let's review this later.
+ (let* ((run t)
+ (d1 (sb-thread:make-thread (lambda ()
+ (loop while run
+ do (defclass test-1 () ((a :initform :new-a)))
+ (write-char #\1)
+ #-win32 (force-output)))
+ :name "d1"))
+ (d2 (sb-thread:make-thread (lambda ()
+ (loop while run
+ do (defclass test-2 () ((b :initform :new-b)))
+ (write-char #\2)
+ #-win32 (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)
+ #-win32 (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)
+ #-win32 (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))
+ (force-output)))
+(format t "parallel defclass test done~%")
+
+(with-test (:name (:deadlock-detection :interrupts) :fails-on :win32)
+ #+win32 ;be more explicit than just :skipped-on
+ (error "not attempting, because of deadlock error in background thread")
+ (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))))))))
+
+(with-test (:name :interrupt-io-unnamed-pipe)
+ (let (result)
+ (labels
+ ((reader (fd)
+ (let ((stream (sb-sys:make-fd-stream fd
+ :element-type :default
+ :serve-events nil)))
+ (time
+ (let ((ok (handler-case
+ (catch 'stop
+ (progn
+ (read-char stream)
+ (sleep 0.1)
+ (sleep 0.1)
+ (sleep 0.1)))
+ (error (c)
+ c))))
+ (setf result ok)
+ (progn
+ (format *trace-output* "~&=> ~A~%" ok)
+ (force-output *trace-output*))))
+ (sleep 2)
+ (ignore-errors (close stream))))
+
+ (writer ()
+ (multiple-value-bind (read write)
+ (sb-unix:unix-pipe)
+ (let* ((reader (sb-thread:make-thread (lambda () (reader read))))
+ (stream (sb-sys:make-fd-stream write
+ :output t
+ :element-type :default
+ :serve-events nil))
+ (ok :ok))
+ (sleep 1)
+ (sb-thread:interrupt-thread reader (lambda ()
+ (print :throwing)
+ (force-output)
+ (throw 'stop ok)))
+ (sleep 1)
+ (setf ok :not-ok)
+ (write-char #\x stream)
+ (close stream)
+ (sb-thread:join-thread reader)))))
+ (writer))
+ (assert (eq result :ok))))
+
+(with-test (:name :thread-alloca)
+ (sb-ext:run-program "sh"
+ '("run-compiler.sh" "-sbcl-pic" "-sbcl-shared"
+ "alloca.c" "-o" "alloca.so")
+ :search t)
+ (load-shared-object (truename "alloca.so"))