-
;;;; miscellaneous tests of thread stuff
;;;; This software is part of the SBCL system. See the README file for
;;;; 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")
+
+(setf sb-unix::*on-dangerous-select* :error)
(defun wait-for-threads (threads)
- (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
+ (mapc (lambda (thread) (sb-thread:join-thread thread :default nil)) threads)
+ (assert (not (some #'sb-thread:thread-alive-p threads))))
(assert (eql 1 (length (list-all-threads))))
(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)
+ `(defun ,name (x)
+ (let* ((old (,accessor x ,@args))
+ (new (1+ old)))
+ (loop until (eq old (sb-ext:compare-and-swap (,accessor x ,@args) old new))
+ do (setf old (,accessor x ,@args)
+ new (1+ old)))
+ new)))
+
+(defstruct cas-struct (slot 0))
+
+(defincf incf-car car)
+(defincf incf-cdr cdr)
+(defincf incf-slot cas-struct-slot)
+(defincf incf-symbol-value symbol-value)
+(defincf incf-svref/1 svref 1)
+(defincf incf-svref/0 svref 0)
+
+(defmacro def-test-cas (name init incf op)
+ `(progn
+ (defun ,name (n)
+ (declare (fixnum n))
+ (let* ((x ,init)
+ (run nil)
+ (threads
+ (loop repeat 10
+ collect (sb-thread:make-thread
+ (lambda ()
+ (loop until run
+ do (sb-thread:thread-yield))
+ (loop repeat n do (,incf x)))))))
+ (setf run t)
+ (dolist (th threads)
+ (sb-thread:join-thread th))
+ (assert (= (,op x) (* 10 n)))))
+ (,name 200000)))
+
+(def-test-cas test-cas-car (cons 0 nil) incf-car car)
+(def-test-cas test-cas-cdr (cons nil 0) incf-cdr cdr)
+(def-test-cas test-cas-slot (make-cas-struct) incf-slot cas-struct-slot)
+(def-test-cas test-cas-value (let ((x '.x.))
+ (set x 0)
+ x)
+ incf-symbol-value symbol-value)
+(def-test-cas test-cas-svref/0 (vector 0 nil) incf-svref/0 (lambda (x)
+ (svref x 0)))
+(def-test-cas test-cas-svref/1 (vector nil 0) incf-svref/1 (lambda (x)
+ (svref x 1)))
+(format t "~&compare-and-swap tests done~%")
+
(let ((old-threads (list-all-threads))
(thread (make-thread (lambda ()
(assert (find *current-thread* *all-threads*))
(sleep 3)
(assert (not (thread-alive-p thread))))
+(with-test (:name '(:join-thread :nlx :default))
+ (let ((sym (gensym)))
+ (assert (eq sym (join-thread (make-thread (lambda () (sb-ext:quit)))
+ :default sym)))))
+
+(with-test (:name '(:join-thread :nlx :error))
+ (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)
+ (multiple-value-list
+ (join-thread (make-thread (lambda () (values 1 2 3))))))))
+
;;; We had appalling scaling properties for a while. Make sure they
;;; don't reappear.
(defun scaling-test (function &optional (nthreads 5))
#-sunos "cc" #+sunos "gcc"
(or #+(or linux freebsd sunos) '(#+x86-64 "-fPIC"
"-shared" "-o" "threads-foreign.so" "threads-foreign.c")
- #+darwin '("-dynamiclib" "-o" "threads-foreign.so" "threads-foreign.c")
+ #+darwin '(#+x86-64 "-arch" #+x86-64 "x86_64"
+ "-dynamiclib" "-o" "threads-foreign.so" "threads-foreign.c")
(error "Missing shared library compilation options for this platform"))
:search t)
-(sb-alien:load-shared-object "threads-foreign.so")
+(sb-alien:load-shared-object (truename "threads-foreign.so"))
(sb-alien:define-alien-routine loop-forever sb-alien:void)
-
+(delete-file "threads-foreign.c")
;;; elementary "can we get a lock and release it again"
(let ((l (make-mutex :name "foo"))
(assert (ours-p (mutex-value l)) nil "5"))
(assert (eql (mutex-value l) nil) nil "6")))
+(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)))))
+
(let ((l (make-spinlock :name "spinlock")))
- (assert (eql (spinlock-value l) 0) nil "1")
+ (assert (eql (spinlock-value l) nil) ((spinlock-value l))
+ "spinlock not free (1)")
(with-spinlock (l)
- (assert (eql (spinlock-value l) 1) nil "2"))
- (assert (eql (spinlock-value l) 0) nil "3"))
+ (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
(lambda ()
(princ ".") (force-output)
(assert (thread-alive-p *current-thread*))
- (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
+ (assert
+ (not (logbitp 0 SB-KERNEL:*PSEUDO-ATOMIC-BITS*))))))
(terminate-thread c)
(wait-for-threads (list c)))
(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)
(force-output)
(sb-ext:quit :unix-status 1)))))))
-(let* ((nanosleep-errno (progn
+;; (nanosleep -1 0) does not fail on FreeBSD
+(let* (#-freebsd
+ (nanosleep-errno (progn
(sb-unix:nanosleep -1 0)
(sb-unix::get-errno)))
(open-errno (progn
(sb-unix::get-errno)))
(threads
(list
+ #-freebsd
(exercise-syscall (lambda () (sb-unix:nanosleep -1 0)) nanosleep-errno)
(exercise-syscall (lambda () (open "no-such-file"
:if-does-not-exist nil))
(format t "~&thread startup sigmask test done~%")
+;; FIXME: What is this supposed to test?
(sb-debug::enable-debugger)
(let* ((main-thread *current-thread*)
(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)))))
+ (interrupt-thread main-thread #'continue))
+ :name "interruptor")))
(with-session-lock (*session*)
(sleep 3))
(loop while (thread-alive-p interruptor-thread)))
(format t "~&binding test done~%")
-;; Try to corrupt the NEXT-VECTOR. Operations on a hash table with a
-;; cyclic NEXT-VECTOR can loop endlessly in a WITHOUT-GCING form
-;; causing the next gc hang SBCL.
-(with-test (:name (:hash-table-thread-safety))
+;;; HASH TABLES
+
+(defvar *errors* nil)
+
+(defun oops (e)
+ (setf *errors* e)
+ (format t "~&oops: ~A in ~S~%" e *current-thread*)
+ (sb-debug:backtrace)
+ (catch 'done))
+
+(with-test (:name (:unsynchronized-hash-table))
+ ;; 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.
(let* ((hash (make-hash-table))
+ (*errors* nil)
(threads (list (sb-thread:make-thread
(lambda ()
- (loop
- ;;(princ "1") (force-output)
- (setf (gethash (random 100) hash) 'h))))
+ (catch 'done
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ ;;(princ "1") (force-output)
+ (setf (gethash (random 100) hash) 'h)))))
+ :name "writer")
(sb-thread:make-thread
(lambda ()
- (loop
- ;;(princ "2") (force-output)
- (remhash (random 100) hash))))
+ (catch 'done
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ ;;(princ "2") (force-output)
+ (remhash (random 100) hash)))))
+ :name "reader")
(sb-thread:make-thread
(lambda ()
- (loop
- (sleep (random 1.0))
- (sb-ext:gc :full t)))))))
+ (catch 'done
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ (sleep (random 1.0))
+ (sb-ext:gc :full t)))))
+ :name "collector"))))
(unwind-protect
- (sleep 5)
+ (sleep 10)
(mapc #'sb-thread:terminate-thread threads))))
-(format t "~&hash table test done~%")
+(format t "~&unsynchronized hash table test done~%")
+
+(with-test (:name (:synchronized-hash-table))
+ (let* ((hash (make-hash-table :synchronized t))
+ (*errors* nil)
+ (threads (list (sb-thread:make-thread
+ (lambda ()
+ (catch 'done
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ ;;(princ "1") (force-output)
+ (setf (gethash (random 100) hash) 'h)))))
+ :name "writer")
+ (sb-thread:make-thread
+ (lambda ()
+ (catch 'done
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ ;;(princ "2") (force-output)
+ (remhash (random 100) hash)))))
+ :name "reader")
+ (sb-thread:make-thread
+ (lambda ()
+ (catch 'done
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ (sleep (random 1.0))
+ (sb-ext:gc :full t)))))
+ :name "collector"))))
+ (unwind-protect
+ (sleep 10)
+ (mapc #'sb-thread:terminate-thread threads))
+ (assert (not *errors*))))
+
+(format t "~&synchronized hash table test done~%")
+
+(with-test (:name (:hash-table-parallel-readers))
+ (let ((hash (make-hash-table))
+ (*errors* nil))
+ (loop repeat 50
+ do (setf (gethash (random 100) hash) 'xxx))
+ (let ((threads (list (sb-thread:make-thread
+ (lambda ()
+ (catch 'done
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ until (eq t (gethash (random 100) hash))))))
+ :name "reader 1")
+ (sb-thread:make-thread
+ (lambda ()
+ (catch 'done
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ until (eq t (gethash (random 100) hash))))))
+ :name "reader 2")
+ (sb-thread:make-thread
+ (lambda ()
+ (catch 'done
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ until (eq t (gethash (random 100) hash))))))
+ :name "reader 3")
+ (sb-thread:make-thread
+ (lambda ()
+ (catch 'done
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ (sleep (random 1.0))
+ (sb-ext:gc :full t)))))
+ :name "collector"))))
+ (unwind-protect
+ (sleep 10)
+ (mapc #'sb-thread:terminate-thread threads))
+ (assert (not *errors*)))))
+
+(format t "~&multiple reader hash table test done~%")
+
+(with-test (:name (:hash-table-single-accessor-parallel-gc))
+ (let ((hash (make-hash-table))
+ (*errors* nil))
+ (let ((threads (list (sb-thread:make-thread
+ (lambda ()
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ (let ((n (random 100)))
+ (if (gethash n hash)
+ (remhash n hash)
+ (setf (gethash n hash) 'h))))))
+ :name "accessor")
+ (sb-thread:make-thread
+ (lambda ()
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ (sleep (random 1.0))
+ (sb-ext:gc :full t))))
+ :name "collector"))))
+ (unwind-protect
+ (sleep 10)
+ (mapc #'sb-thread:terminate-thread threads))
+ (assert (not *errors*)))))
+
+(format t "~&single accessor hash table test~%")
+
#| ;; a cll post from eric marsden
| (defun crash ()
| (setq *debugger-hook*
(let* ((ok t)
(threads (loop for i from 0 to 10
collect (sb-thread:make-thread
- (let ((i i))
- (lambda ()
- (dotimes (j 100)
- (write-char #\-)
- (finish-output)
- (let ((n (infodb-test)))
- (unless (zerop n)
- (setf ok nil)
- (format t "N != 0 (~A)~%" n)
- (quit))))))))))
+ (lambda ()
+ (dotimes (j 100)
+ (write-char #\-)
+ (finish-output)
+ (let ((n (infodb-test)))
+ (unless (zerop n)
+ (setf ok nil)
+ (format t "N != 0 (~A)~%" n)
+ (sb-ext:quit)))))))))
(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)
+ (sb-thread:make-thread
+ (lambda ()
+ (sleep (random 0.001)))
+ :name (list :sleep i))
+ (sb-thread:make-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 (list :gc 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))))
+
+(with-test (:name (:funcallable-instances))
+ ;; 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))
+ (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~%")