X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=f32588e9d10953090ea0841231e3a12a87d74e64;hb=3fa2feb10ab827fc6cc2a85287e78b6e66b7bf4d;hp=0b85990f0d65a2f91ebe1336280fcc2775e6ae55;hpb=1cf1afff10cfc48a2f4a26fd4533531081602219;p=sbcl.git diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 0b85990..f32588e 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -11,11 +11,14 @@ ;;;; 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) (mapc (lambda (thread) (sb-thread:join-thread thread :default nil)) threads) (assert (not (some #'sb-thread:thread-alive-p threads)))) @@ -39,8 +42,100 @@ (with-mutex (mutex) mutex)) +(sb-alien:define-alien-routine "check_deferrables_blocked_or_lose" + void + (where sb-alien:unsigned-long)) +(sb-alien:define-alien-routine "check_deferrables_unblocked_or_lose" + void + (where sb-alien:unsigned-long)) + +(with-test (:name (:interrupt-thread :deferrables-blocked)) + (sb-thread:interrupt-thread sb-thread:*current-thread* + (lambda () + (check-deferrables-blocked-or-lose 0)))) + +(with-test (:name (:interrupt-thread :deferrables-unblocked)) + (sb-thread:interrupt-thread sb-thread:*current-thread* + (lambda () + (with-interrupts + (check-deferrables-unblocked-or-lose 0))))) + +(with-test (:name (:interrupt-thread :nlx)) + (catch 'xxx + (sb-thread:interrupt-thread sb-thread:*current-thread* + (lambda () + (check-deferrables-blocked-or-lose 0) + (throw 'xxx nil)))) + (check-deferrables-unblocked-or-lose 0)) + #-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 0) + (sb-thread::get-spinlock spinlock) + (check-deferrables-unblocked-or-lose 0) + (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*)) @@ -58,7 +153,8 @@ :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) @@ -103,9 +199,9 @@ "-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")) @@ -127,16 +223,35 @@ (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 @@ -341,7 +456,8 @@ (format t "~&interrupt test done~%") -(defparameter *interrupt-count* 0) +(defstruct counter (n 0 :type sb-vm:word)) +(defvar *interrupt-counter* (make-counter)) (declaim (notinline check-interrupt-count)) (defun check-interrupt-count (i) @@ -356,21 +472,58 @@ (princ cond) (sb-debug:backtrace most-positive-fixnum)))) - (loop (check-interrupt-count *interrupt-count*))))))) + (loop (check-interrupt-count (counter-n *interrupt-counter*)))))))) (let ((func (lambda () (princ ".") (force-output) - (sb-impl::atomic-incf/symbol *interrupt-count*)))) - (setq *interrupt-count* 0) + (sb-ext:atomic-incf (counter-n *interrupt-counter*))))) + (setf (counter-n *interrupt-counter*) 0) (dotimes (i 100) (sleep (random 0.1d0)) (interrupt-thread c func)) - (loop until (= *interrupt-count* 100) do (sleep 0.1)) + (loop until (= (counter-n *interrupt-counter*) 100) do (sleep 0.1)) (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) @@ -470,14 +623,19 @@ (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))) @@ -556,31 +714,153 @@ (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* @@ -594,6 +874,31 @@ | (mp:make-process #'roomy))) |# +;;; KLUDGE: No deadlines while waiting on lutex-based condition variables. This test +;;; would just hang. +#-sb-lutex +(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")) @@ -631,6 +936,96 @@ (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. +;;; +#-sb-lutex ; See KLUDGE above: no deadlines for condition-wait+lutexes. +(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))))))) + (setq B (sb-thread:make-thread + #'(lambda () + (thread-yield) + (handler-bind + ((sb-sys:deadline-timeout + #'(lambda (c) + ;; We came here through the call to GET-MUTEX + ;; 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))))))) + (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: fall through.")))))) + (with-test (:name (:mutex :finalization)) (let ((a nil)) (dotimes (i 500000) @@ -716,7 +1111,7 @@ ;; 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))) @@ -800,5 +1195,53 @@ (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~%")