X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=3672c92abc727d4ab7800d1cb627270d6de75e6a;hb=85e1967527101d2d8a4c0f5d37857cf731690733;hp=cbf5ce6a34cbe1226bb1c88f817facacbbdebd2f;hpb=828bcd9589641a560e01c2f2bc9134a0aaacd552;p=sbcl.git diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index cbf5ce6..3672c92 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -11,17 +11,48 @@ ;;;; 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)))) + +(assert (eql 1 (length (list-all-threads)))) + +(assert (eq *current-thread* + (find (thread-name *current-thread*) (list-all-threads) + :key #'thread-name :test #'equal))) + +(assert (thread-alive-p *current-thread*)) + +(let ((a 0)) + (interrupt-thread *current-thread* (lambda () (setq a 1))) + (assert (eql a 1))) + +(let ((spinlock (make-spinlock))) + (with-spinlock (spinlock))) + +(let ((mutex (make-mutex))) + (with-mutex (mutex) + mutex)) + +#-sb-thread (sb-ext:quit :unix-status 104) ;;; compare-and-swap (defmacro defincf (name accessor &rest args) `(defun ,name (x) (let* ((old (,accessor x ,@args)) - (new (1+ old))) + (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 (1+ old))) new))) (defstruct cas-struct (slot 0)) @@ -38,62 +69,33 @@ (defun ,name (n) (declare (fixnum n)) (let* ((x ,init) - (run nil) - (threads - (loop repeat 10 - collect (sb-thread:make-thread - (lambda () - (loop until run) - (loop repeat n do (,incf x))))))) - (setf run t) - (dolist (th threads) - (sb-thread:join-thread th)) - (assert (= (,op x) (* 10 n))))) + (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) + (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))) + (svref x 0))) (def-test-cas test-cas-svref/1 (vector nil 0) incf-svref/1 (lambda (x) - (svref x 1))) + (svref x 1))) (format t "~&compare-and-swap tests done~%") -(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)))) - -(assert (eql 1 (length (list-all-threads)))) - -(assert (eq *current-thread* - (find (thread-name *current-thread*) (list-all-threads) - :key #'thread-name :test #'equal))) - -(assert (thread-alive-p *current-thread*)) - -(let ((a 0)) - (interrupt-thread *current-thread* (lambda () (setq a 1))) - (assert (eql a 1))) - -(let ((spinlock (make-spinlock))) - (with-spinlock (spinlock))) - -(let ((mutex (make-mutex))) - (with-mutex (mutex) - mutex)) - -#-sb-thread (sb-ext:quit :unix-status 104) - (let ((old-threads (list-all-threads)) (thread (make-thread (lambda () (assert (find *current-thread* *all-threads*)) @@ -156,7 +158,7 @@ "-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") @@ -630,31 +632,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* @@ -790,7 +914,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))) @@ -874,5 +998,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~%")