X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=3800bbc37d1f4561312910b92b54eed98f630e9d;hb=055ce77ed25e387a4061653709fe1e03c193eb92;hp=d2140d4c81384784f54208e03c0c4a5cb81cc93c;hpb=eda073ca21407c12c30b5d27ab9dbdd5e446a4b8;p=sbcl.git diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index d2140d4..3800bbc 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,11 @@ (in-package "SB-THREAD") ; this is white-box testing, really (use-package :test-util) +(use-package "ASSERTOID") (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)))) @@ -51,6 +52,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)) @@ -319,7 +333,8 @@ (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))) @@ -419,7 +434,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 @@ -428,6 +445,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)) @@ -638,21 +656,148 @@ (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-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~%")