X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=8914dda661ad49f5541efa1a7e414fd9aa384c61;hb=6d36f2d6954cb79e3c88fef33fe0c3ad63deaea8;hp=91184e0f960a021d2ab31c0845bb2cb2d9352890;hpb=00616528986d795d1335a0591371e1ac9d958eed;p=sbcl.git diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 91184e0..8914dda 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) @@ -126,7 +126,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 +154,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 +198,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") @@ -336,6 +332,62 @@ (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)) + #+sb-lutex + (error "Mutex timeout not supported here.") + (let ((m (make-mutex))) + (with-mutex (m) + (assert (null (join-thread (make-thread + #'(lambda () + (grab-mutex m :timeout 0.1))))))))) + +(with-test (:name (:grab-mutex :timeout :acquisition-success)) + #+sb-lutex + (error "Mutex timeout not supported here.") + (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)) + #+sb-lutex + (error "Mutex timeout not supported here.") + (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 :timeout 0.0) + (sb-sys:deadline-timeout () + :deadline)))))) + :deadline))))) + +(with-test (:name (:grab-mutex :waitp+deadline)) + #+sb-lutex + (error "Mutex timeout not supported here.") + (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) @@ -507,6 +559,8 @@ (defun alloc-stuff () (copy-list '(1 2 3 4 5))) (with-test (:name (:interrupt-thread :interrupt-consing-child)) + #+darwin + (error "Hangs on Darwin.") (let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff)))))) (let ((killers (loop repeat 4 collect @@ -524,7 +578,10 @@ (format t "~&multi interrupt test done~%") +#+(or x86 x86-64) ;; x86oid-only, see internal commentary. (with-test (:name (:interrupt-thread :interrupt-consing-child :again)) + #+darwin + (error "Hangs on Darwin.") (let ((c (make-thread (lambda () (loop (alloc-stuff)))))) ;; NB this only works on x86: other ports don't have a symbol for ;; pseudo-atomic atomicity @@ -612,6 +669,8 @@ (assert (sb-thread:join-thread thread)))) (with-test (:name (:two-threads-running-gc)) + #+darwin + (error "Hangs on Darwin.") (let (a-done b-done) (make-thread (lambda () (dotimes (i 100) @@ -933,6 +992,8 @@ (format t "~&multiple reader hash table test done~%") (with-test (:name (:hash-table-single-accessor-parallel-gc)) + #+darwin + (error "Prone to hang on Darwin due to interrupt issues.") (let ((hash (make-hash-table)) (*errors* nil)) (let ((threads (list (sb-thread:make-thread @@ -971,31 +1032,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")) @@ -1065,6 +1101,8 @@ (assert (not deadline-handler-run-twice?)))) (with-test (:name (:condition-wait :signal-deadline-with-interrupts-enabled)) + #+darwin + (error "Bad Darwin") (let ((mutex (sb-thread:make-mutex)) (waitq (sb-thread:make-waitqueue)) (A-holds? :unknown) @@ -1164,6 +1202,8 @@ (format t "infodb test done~%") (with-test (:name (:backtrace)) + #+darwin + (error "Prone to crash on Darwin, cause unknown.") ;; 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 @@ -1183,6 +1223,8 @@ (format t "~&starting gc deadlock test: WARNING: THIS TEST WILL HANG ON FAILURE!~%") (with-test (:name (:gc-deadlock)) + #+darwin + (error "Prone to hang on Darwin due to interrupt issues.") ;; 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 +1243,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 +1253,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 +1331,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~%")