X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=71eb25e96912cd83b90e41473c04d11711f5d3fe;hb=722a3f7ec83e075a483161ffff76e1392c66cc22;hp=91184e0f960a021d2ab31c0845bb2cb2d9352890;hpb=00616528986d795d1335a0591371e1ac9d958eed;p=sbcl.git diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 91184e0..71eb25e 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -17,7 +17,7 @@ (use-package :test-util) (use-package "ASSERTOID") -(setf sb-unix::*on-dangerous-select* :error) +(setf sb-unix::*on-dangerous-wait* :error) (defun wait-for-threads (threads) (mapc (lambda (thread) (sb-thread:join-thread thread :default nil)) threads) @@ -37,10 +37,6 @@ (with-mutex (mutex) mutex))) -(with-test (:name (:with-spinlock :basics)) - (let ((spinlock (make-spinlock))) - (with-spinlock (spinlock)))) - (sb-alien:define-alien-routine "check_deferrables_blocked_or_lose" void (where sb-alien:unsigned-long)) @@ -76,19 +72,19 @@ ;;;; Now the real tests... -(with-test (:name (:interrupt-thread :deferrables-unblocked-by-spinlock)) - (let ((spinlock (sb-thread::make-spinlock)) +(with-test (:name (:interrupt-thread :deferrables-unblocked-by-lock)) + (let ((lock (sb-thread::make-mutex)) (thread (sb-thread:make-thread (lambda () (loop (sleep 1)))))) - (sb-thread::get-spinlock spinlock) + (sb-thread::grab-mutex lock) (sb-thread:interrupt-thread thread (lambda () (check-deferrables-blocked-or-lose 0) - (sb-thread::get-spinlock spinlock) + (sb-thread::grab-mutex lock) (check-deferrables-unblocked-or-lose 0) (sb-ext:quit))) (sleep 1) - (sb-thread::release-spinlock spinlock))) + (sb-thread::release-mutex lock))) ;;; compare-and-swap @@ -126,7 +122,7 @@ (setf run t) (dolist (th threads) (sb-thread:join-thread th)) - (assert (= (,op x) (* 10 n)))))) + (assert (= (,op x) (* 10 n)))))) (,name 200000)))) (def-test-cas test-cas-car (cons 0 nil) incf-car car) @@ -154,16 +150,16 @@ (sleep 3) (assert (not (thread-alive-p thread)))) -(with-test (:name '(:join-thread :nlx :default)) +(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)) +(with-test (:name (:join-thread :nlx :error)) (raises-error? (join-thread (make-thread (lambda () (sb-ext:quit)))) join-thread-error)) -(with-test (:name '(:join-thread :multiple-values)) +(with-test (:name (:join-thread :multiple-values)) (assert (equal '(1 2 3) (multiple-value-list (join-thread (make-thread (lambda () (values 1 2 3)))))))) @@ -198,14 +194,10 @@ (with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede) (format o "void loop_forever() { while(1) ; }~%")) -(sb-ext:run-program - #-sunos "cc" #+sunos "gcc" - (or #+(or linux freebsd sunos) '(#+x86-64 "-fPIC" - "-shared" "-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-ext:run-program "/bin/sh" + '("run-compiler.sh" "-sbcl-pic" "-sbcl-shared" + "-o" "threads-foreign.so" "threads-foreign.c") + :environment (test-util::test-env)) (sb-alien:load-shared-object (truename "threads-foreign.so")) (sb-alien:define-alien-routine loop-forever sb-alien:void) (delete-file "threads-foreign.c") @@ -233,38 +225,11 @@ (assert (ours-p (mutex-value l)) nil "5")) (assert (eql (mutex-value l) nil) nil "6")))) -(with-test (:name (:with-recursive-spinlock :basics)) - (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))))) - -(with-test (:name (:spinlock :more-basics)) - (let ((l (make-spinlock :name "spinlock"))) - (assert (eql (spinlock-value l) nil) ((spinlock-value l)) - "spinlock not free (1)") - (with-spinlock (l) - (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 (with-test (:name (:sleep :continue-sleeping-after-interrupt)) @@ -336,6 +301,63 @@ (format t "contention ~A ~A~%" kid1 kid2) (wait-for-threads (list kid1 kid2)))))) +;;; GRAB-MUTEX + +(with-test (:name (:grab-mutex :waitp nil)) + (let ((m (make-mutex))) + (with-mutex (m) + (assert (null (join-thread (make-thread + #'(lambda () + (grab-mutex m :waitp nil))))))))) + +(with-test (:name (:grab-mutex :timeout :acquisition-fail)) + (let ((m (make-mutex)) + (w (make-semaphore))) + (with-mutex (m) + (let ((th (make-thread + #'(lambda () + (prog1 + (grab-mutex m :timeout 0.1) + (signal-semaphore w)))))) + ;; Wait for it to -- otherwise the detect the deadlock chain + ;; from JOIN-THREAD. + (wait-on-semaphore w) + (assert (null (join-thread th))))))) + +(with-test (:name (:grab-mutex :timeout :acquisition-success)) + (let ((m (make-mutex)) + (child)) + (with-mutex (m) + (setq child (make-thread #'(lambda () (grab-mutex m :timeout 1.0)))) + (sleep 0.2)) + (assert (eq (join-thread child) 't)))) + +(with-test (:name (:grab-mutex :timeout+deadline)) + (let ((m (make-mutex)) + (w (make-semaphore))) + (with-mutex (m) + (let ((th (make-thread #'(lambda () + (sb-sys:with-deadline (:seconds 0.0) + (handler-case + (grab-mutex m :timeout 0.0) + (sb-sys:deadline-timeout () + (signal-semaphore w) + :deadline))))))) + (wait-on-semaphore w) + (assert (eq (join-thread th) :deadline)))))) + +(with-test (:name (:grab-mutex :waitp+deadline)) + (let ((m (make-mutex))) + (with-mutex (m) + (assert (eq (join-thread + (make-thread #'(lambda () + (sb-sys:with-deadline (:seconds 0.0) + (handler-case + (grab-mutex m :waitp nil) + (sb-sys:deadline-timeout () + :deadline)))))) + 'nil))))) + ;;; semaphores (defmacro raises-timeout-p (&body body) @@ -524,6 +546,7 @@ (format t "~&multi interrupt test done~%") +#+(or x86 x86-64) ;; x86oid-only, see internal commentary. (with-test (:name (:interrupt-thread :interrupt-consing-child :again)) (let ((c (make-thread (lambda () (loop (alloc-stuff)))))) ;; NB this only works on x86: other ports don't have a symbol for @@ -790,11 +813,12 @@ ;; now SOMETHING is gc'ed and the binding stack looks like this: 0, ;; 0, SOMETHING, 0 (because the symbol slots are zeroed on ;; unbinding but values are not). - (let ((*x* nil)) + (let ((*x* nil) + (binding-pointer-delta (ash 2 (- sb-vm:word-shift sb-vm:n-fixnum-tag-bits)))) ;; bump bsp as if a BIND had just started - (incf sb-vm::*binding-stack-pointer* 2) + (incf sb-vm::*binding-stack-pointer* binding-pointer-delta) (wait-for-gc) - (decf sb-vm::*binding-stack-pointer* 2)))) + (decf sb-vm::*binding-stack-pointer* binding-pointer-delta)))) (with-test (:name (:binding-stack-gc-safety)) (let (threads) @@ -821,7 +845,13 @@ (sb-debug:backtrace) (catch 'done)) -(with-test (:name (:unsynchronized-hash-table)) +(with-test (:name (:unsynchronized-hash-table) + ;; FIXME: This test occasionally eats out craploads + ;; of heap instead of expected error early. Not 100% + ;; sure if it would finish as expected, but since it + ;; hits swap on my system I'm not likely to find out + ;; soon. Disabling for now. -- nikodemus + :skipped-on :sbcl) ;; 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. @@ -971,31 +1001,6 @@ | (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")) @@ -1036,30 +1041,29 @@ ;;; 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 + (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)))))))) + (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?)))) @@ -1090,7 +1094,8 @@ (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:condition-wait waitq mutex))))) + :name "A")) (setq B (sb-thread:make-thread #'(lambda () (thread-yield) @@ -1109,7 +1114,8 @@ (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:condition-wait waitq mutex))))) + :name "B")) (sb-thread:join-thread A) (sb-thread:join-thread B) (let ((A-result (list A-holds? A-interrupts-enabled?)) @@ -1121,7 +1127,10 @@ ;; 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.")))))) + (t + (error "Failure: fell through wit A: ~S, B: ~S" + A-result + B-result)))))) (with-test (:name (:mutex :finalization)) (let ((a nil)) @@ -1163,7 +1172,7 @@ (format t "infodb test done~%") -(with-test (:name (:backtrace)) +(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 @@ -1182,7 +1191,7 @@ (format t "~&starting gc deadlock test: WARNING: THIS TEST WILL HANG ON FAILURE!~%") -(with-test (:name (:gc-deadlock)) +(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 @@ -1201,7 +1210,7 @@ (sb-thread:make-thread (lambda () (sleep (random 0.001))) - :name (list :sleep i)) + :name (format nil "SLEEP-~D" i)) (sb-thread:make-thread (lambda () ;; KLUDGE: what we are doing here is explicit, @@ -1211,7 +1220,7 @@ (sb-thread::with-all-threads-lock (sb-thread::with-session-lock (sb-thread::*session*) (sb-ext:gc)))) - :name (list :gc i))) + :name (format nil "GC-~D" i))) (error (e) (format t "~%error creating thread ~D: ~A -- backing off for retry~%" i e) (sleep 0.1) @@ -1289,7 +1298,7 @@ (format t "ok~%") (force-output)) -(with-test (:name '(:hash-cache :subtypep)) +(with-test (:name (:hash-cache :subtypep)) (dotimes (i 10) (sb-thread:make-thread #'subtypep-hash-cache-test))) (format t "hash-cache tests done~%") @@ -1342,3 +1351,55 @@ (format t "~%joined ~S~%" (sb-thread:thread-name th))) (list d1 d2 d3 i)))) (format t "parallel defclass test done~%") + +(with-test (:name (:deadlock-detection :interrupts)) + (let* ((m1 (sb-thread:make-mutex :name "M1")) + (m2 (sb-thread:make-mutex :name "M2")) + (t1 (sb-thread:make-thread + (lambda () + (sb-thread:with-mutex (m1) + (sleep 0.3) + :ok)) + :name "T1")) + (t2 (sb-thread:make-thread + (lambda () + (sleep 0.1) + (sb-thread:with-mutex (m1 :wait-p t) + (sleep 0.2) + :ok)) + :name "T2"))) + (sleep 0.2) + (sb-thread:interrupt-thread t2 (lambda () + (sb-thread:with-mutex (m2 :wait-p t) + (sleep 0.3)))) + (sleep 0.05) + (sb-thread:interrupt-thread t1 (lambda () + (sb-thread:with-mutex (m2 :wait-p t) + (sleep 0.3)))) + ;; both threads should finish without a deadlock or deadlock + ;; detection error + (let ((res (list (sb-thread:join-thread t1) + (sb-thread:join-thread t2)))) + (assert (equal '(:ok :ok) res))))) + +(with-test (:name (:deadlock-detection :gc)) + ;; To semi-reliably trigger the error (in SBCL's where) + ;; it was present you had to run this for > 30 seconds, + ;; but that's a bit long for a single test. + (let* ((stop (+ 5 (get-universal-time))) + (m1 (sb-thread:make-mutex :name "m1")) + (t1 (sb-thread:make-thread + (lambda () + (loop until (> (get-universal-time) stop) + do (sb-thread:with-mutex (m1) + (eval `(make-array 24)))) + :ok))) + (t2 (sb-thread:make-thread + (lambda () + (loop until (> (get-universal-time) stop) + do (sb-thread:with-mutex (m1) + (eval `(make-array 24)))) + :ok)))) + (let ((res (list (sb-thread:join-thread t1) + (sb-thread:join-thread t2)))) + (assert (equal '(:ok :ok) res)))))