;;;; absoluely no warranty. See the COPYING and CREDITS files for
;;;; more information.
-(in-package "SB-THREAD") ; this is white-box testing, really
+; WHITE-BOX TESTS
+(in-package "SB-THREAD")
(use-package :test-util)
(use-package "ASSERTOID")
(with-mutex (mutex)
mutex))
+(sb-alien:define-alien-routine "check_deferrables_blocked_or_lose"
+ void)
+(sb-alien:define-alien-routine "check_deferrables_unblocked_or_lose"
+ void)
+
+(with-test (:name (:interrupt-thread :deferrables-blocked))
+ (sb-thread:interrupt-thread sb-thread:*current-thread*
+ (lambda ()
+ (check-deferrables-blocked-or-lose))))
+
+(with-test (:name (:interrupt-thread :deferrables-unblocked))
+ (sb-thread:interrupt-thread sb-thread:*current-thread*
+ (lambda ()
+ (with-interrupts
+ (check-deferrables-unblocked-or-lose)))))
+
+(with-test (:name (:interrupt-thread :nlx))
+ (catch 'xxx
+ (sb-thread:interrupt-thread sb-thread:*current-thread*
+ (lambda ()
+ (check-deferrables-blocked-or-lose)
+ (throw 'xxx nil))))
+ (check-deferrables-unblocked-or-lose))
+
#-sb-thread (sb-ext:quit :unix-status 104)
+(with-test (:name (:interrupt-thread :deferrables-unblocked-by-spinlock))
+ (let ((spinlock (sb-thread::make-spinlock))
+ (thread (sb-thread:make-thread (lambda ()
+ (loop (sleep 1))))))
+ (sb-thread::get-spinlock spinlock)
+ (sb-thread:interrupt-thread thread
+ (lambda ()
+ (check-deferrables-blocked-or-lose)
+ (sb-thread::get-spinlock spinlock)
+ (check-deferrables-unblocked-or-lose)
+ (sb-ext:quit)))
+ (sleep 1)
+ (sb-thread::release-spinlock spinlock)))
+
;;; compare-and-swap
(defmacro defincf (name accessor &rest args)
:default sym)))))
(with-test (:name '(:join-thread :nlx :error))
- (raises-error? (join-thread (make-thread (lambda () (sb-ext:quit))))))
+ (raises-error? (join-thread (make-thread (lambda () (sb-ext:quit))))
+ join-thread-error))
(with-test (:name '(:join-thread :multiple-values))
(assert (equal '(1 2 3)
(format t "~&interrupt count test done~%")
+(defvar *runningp* nil)
+
+(with-test (:name (:interrupt-thread :no-nesting))
+ (let ((thread (sb-thread:make-thread
+ (lambda ()
+ (catch 'xxx
+ (loop))))))
+ (declare (special runningp))
+ (sleep 0.2)
+ (sb-thread:interrupt-thread thread
+ (lambda ()
+ (let ((*runningp* t))
+ (sleep 1))))
+ (sleep 0.2)
+ (sb-thread:interrupt-thread thread
+ (lambda ()
+ (throw 'xxx *runningp*)))
+ (assert (not (sb-thread:join-thread thread)))))
+
+(with-test (:name (:interrupt-thread :nesting))
+ (let ((thread (sb-thread:make-thread
+ (lambda ()
+ (catch 'xxx
+ (loop))))))
+ (declare (special runningp))
+ (sleep 0.2)
+ (sb-thread:interrupt-thread thread
+ (lambda ()
+ (let ((*runningp* t))
+ (sb-sys:with-interrupts
+ (sleep 1)))))
+ (sleep 0.2)
+ (sb-thread:interrupt-thread thread
+ (lambda ()
+ (throw 'xxx *runningp*)))
+ (assert (sb-thread:join-thread thread))))
+
(let (a-done b-done)
(make-thread (lambda ()
(dotimes (i 100)
(interruptor-thread
(make-thread (lambda ()
(sleep 2)
- (interrupt-thread main-thread #'break)
+ (interrupt-thread main-thread
+ (lambda ()
+ (with-interrupts
+ (break))))
(sleep 2)
(interrupt-thread main-thread #'continue))
:name "interruptor")))
| (mp:make-process #'roomy)))
|#
+(with-test (:name (:condition-variable :wait-multiple))
+ (loop repeat 40 do
+ (let ((waitqueue (sb-thread:make-waitqueue :name "Q"))
+ (mutex (sb-thread:make-mutex :name "M"))
+ (failedp nil))
+ (format t ".")
+ (finish-output t)
+ (let ((threads (loop repeat 200
+ collect
+ (sb-thread:make-thread
+ (lambda ()
+ (handler-case
+ (sb-sys:with-deadline (:seconds 0.01)
+ (sb-thread:with-mutex (mutex)
+ (sb-thread:condition-wait waitqueue
+ mutex)
+ (setq failedp t)))
+ (sb-sys:deadline-timeout (c)
+ (declare (ignore c)))))))))
+ (mapc #'sb-thread:join-thread threads)
+ (assert (not failedp))))))
+
(with-test (:name (:condition-variable :notify-multiple))
(flet ((tester (notify-fun)
(let ((queue (make-waitqueue :name "queue"))
;; but the same can happen because of a regular
;; MAKE-THREAD or LIST-ALL-THREADS, and various
;; session functions.
- (sb-thread:with-mutex (sb-thread::*all-threads-lock*)
+ (sb-thread::with-all-threads-lock
(sb-thread::with-session-lock (sb-thread::*session*)
(sb-ext:gc))))
:name (list :gc i)))
(with-test (:name '(:hash-cache :subtypep))
(dotimes (i 10)
(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)))
+ (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~%")
projects / sbcl.git / blobdiff