X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=20ac538d8c59d0f9a9b96c4a7d8860df6be30b3c;hb=088583ae2b22d8d861fbc354568bd24edc0333cb;hp=141cec05f9de3a0c941c97971cd848733391cdff;hpb=a682600e6469735185553ac21c25c50686c54abb;p=sbcl.git diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 141cec0..20ac538 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -68,7 +68,7 @@ (throw 'xxx nil)))) (check-deferrables-unblocked-or-lose 0)) -#-sb-thread (sb-ext:quit :unix-status 104) +#-sb-thread (sb-ext:exit :code 104) ;;;; Now the real tests... @@ -82,7 +82,7 @@ (check-deferrables-blocked-or-lose 0) (sb-thread::grab-mutex lock) (check-deferrables-unblocked-or-lose 0) - (sb-ext:quit))) + (sb-thread:abort-thread))) (sleep 1) (sb-thread::release-mutex lock))) @@ -152,11 +152,11 @@ (with-test (:name (:join-thread :nlx :default)) (let ((sym (gensym))) - (assert (eq sym (join-thread (make-thread (lambda () (sb-ext:quit))) + (assert (eq sym (join-thread (make-thread (lambda () (sb-thread:abort-thread))) :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-thread:abort-thread)))) join-thread-error)) (with-test (:name (:join-thread :multiple-values)) @@ -175,7 +175,7 @@ (sb-thread:make-thread (lambda () (with-mutex (mutex) (sb-thread:condition-wait queue mutex)) - (sb-ext:quit)))) + (sb-thread:abort-thread)))) (let ((start-time (get-internal-run-time))) (funcall function) (prog1 (- (get-internal-run-time) start-time) @@ -487,7 +487,7 @@ (interrupt-thread child (lambda () (format t "child pid ~A~%" *current-thread*) - (when quit-p (sb-ext:quit)))) + (when quit-p (abort-thread)))) (sleep 1) child)) @@ -528,8 +528,7 @@ (defun alloc-stuff () (copy-list '(1 2 3 4 5))) -(with-test (:name (:interrupt-thread :interrupt-consing-child) - :broken-on :darwin) +(with-test (:name (:interrupt-thread :interrupt-consing-child)) (let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff)))))) (let ((killers (loop repeat 4 collect @@ -699,7 +698,7 @@ (sb-unix::strerror) reference-errno) (force-output) - (sb-ext:quit :unix-status 1))))))) + (abort-thread))))))) ;; (nanosleep -1 0) does not fail on FreeBSD (with-test (:name (:exercising-concurrent-syscalls)) @@ -726,13 +725,13 @@ (format t "~&errno test done~%") -(with-test (:name (:terminate-thread-restart)) +(with-test (:name :all-threads-have-abort-restart) (loop repeat 100 do (let ((thread (sb-thread:make-thread (lambda () (sleep 0.1))))) (sb-thread:interrupt-thread thread (lambda () - (assert (find-restart 'sb-thread:terminate-thread))))))) + (assert (find-restart 'abort))))))) (sb-ext:gc :full t) @@ -1167,13 +1166,13 @@ (unless (zerop n) (setf ok nil) (format t "N != 0 (~A)~%" n) - (sb-ext:quit))))))))) + (abort-thread))))))))) (wait-for-threads threads) (assert ok))) (format t "infodb test done~%") -(with-test (:name :backtrace :broken-on :darwin) +(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 @@ -1192,9 +1191,7 @@ (format t "~&starting gc deadlock test: WARNING: THIS TEST WILL HANG ON FAILURE!~%") -(with-test (:name :gc-deadlock - ;; Prone to hang on Darwin due to interrupt issues. - :broken-on :darwin) +(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 @@ -1358,32 +1355,36 @@ (with-test (:name (:deadlock-detection :interrupts)) (let* ((m1 (sb-thread:make-mutex :name "M1")) (m2 (sb-thread:make-mutex :name "M2")) + (t1-can-go (sb-thread:make-semaphore :name "T1 can go")) + (t2-can-go (sb-thread:make-semaphore :name "T2 can go")) (t1 (sb-thread:make-thread (lambda () (sb-thread:with-mutex (m1) - (sleep 0.3) - :ok)) + (sb-thread:wait-on-semaphore t1-can-go) + :ok1)) :name "T1")) (t2 (sb-thread:make-thread (lambda () - (sleep 0.1) + (sb-ext:wait-for (eq t1 (sb-thread:mutex-owner m1))) (sb-thread:with-mutex (m1 :wait-p t) - (sleep 0.2) - :ok)) + (sb-thread:wait-on-semaphore t2-can-go) + :ok2)) :name "T2"))) - (sleep 0.2) + (sb-ext:wait-for (eq m1 (sb-thread::thread-waiting-for t2))) (sb-thread:interrupt-thread t2 (lambda () (sb-thread:with-mutex (m2 :wait-p t) - (sleep 0.3)))) - (sleep 0.05) + (sb-ext:wait-for + (eq m2 (sb-thread::thread-waiting-for t1))) + (sb-thread:signal-semaphore t2-can-go)))) + (sb-ext:wait-for (eq t2 (sb-thread:mutex-owner m2))) (sb-thread:interrupt-thread t1 (lambda () (sb-thread:with-mutex (m2 :wait-p t) - (sleep 0.3)))) + (sb-thread:signal-semaphore t1-can-go)))) ;; 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))))) + (assert (equal '(:ok1 :ok2) res))))) (with-test (:name (:deadlock-detection :gc)) ;; To semi-reliably trigger the error (in SBCL's where) @@ -1406,3 +1407,26 @@ (let ((res (list (sb-thread:join-thread t1) (sb-thread:join-thread t2)))) (assert (equal '(:ok :ok) res))))) + +(with-test (:name :spinlock-api) + (let* ((warned 0) + (funs + (handler-bind ((sb-int:early-deprecation-warning (lambda (_) + (declare (ignore _)) + (incf warned)))) + (list (compile nil `(lambda (lock) + (sb-thread::with-spinlock (lock) + t))) + (compile nil `(lambda () + (sb-thread::make-spinlock :name "foo"))) + (compile nil `(lambda (lock) + (sb-thread::get-spinlock lock))) + (compile nil `(lambda (lock) + (sb-thread::release-spinlock lock))))))) + (assert (eql 4 warned)) + (handler-bind ((warning #'error)) + (destructuring-bind (with make get release) funs + (let ((lock (funcall make))) + (funcall get lock) + (funcall release lock) + (assert (eq t (funcall with lock))))))))