X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=3eb0fe0a74c8fea0578f3b0fd54216dae8339e4c;hb=9837343101c3da7b3a8f94609ec116ec5025436a;hp=793161be81f768b0e7e25364f3e49a45ee8f1fd4;hpb=801730762f17302c33b70398b632aa1393c6722a;p=sbcl.git diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 793161b..3eb0fe0 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -11,8 +11,9 @@ ;;;; 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") @@ -41,8 +42,48 @@ (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) @@ -112,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) @@ -414,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) @@ -429,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) @@ -549,7 +629,10 @@ (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)) :name "interruptor"))) @@ -791,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")) @@ -913,7 +1021,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))) @@ -997,5 +1105,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~%")