X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=867f40830b994f99014ba5f51a4b01f6f165bf9b;hb=365286d3d1ba47647e1af3016305540186283a49;hp=43a60f33a3f44a2dad9daa1a972a90ce2db55e16;hpb=b3907e261afc6af9954b8232b662e04f519f8158;p=sbcl.git diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 43a60f3..867f408 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -1,4 +1,3 @@ - ;;;; miscellaneous tests of thread stuff ;;;; This software is part of the SBCL system. See the README file for @@ -15,9 +14,13 @@ (in-package "SB-THREAD") ; this is white-box testing, really (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)))) @@ -40,6 +43,57 @@ #-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))) + (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) + (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*)) @@ -51,6 +105,19 @@ (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)))))) + +(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)) @@ -85,12 +152,13 @@ #-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: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")) @@ -112,16 +180,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 @@ -420,7 +507,9 @@ (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 @@ -429,6 +518,7 @@ (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)) @@ -452,6 +542,7 @@ (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 @@ -459,7 +550,8 @@ (sleep 2) (interrupt-thread main-thread #'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))) @@ -639,16 +731,15 @@ (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))) @@ -670,3 +761,118 @@ (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-mutex (sb-thread::*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~%") + +(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 "~@" 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~%")