(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)
(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)
(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))))))))
(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")
(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))
+ (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))
+ #+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))
+ (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))
+ #+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)
(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
(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.
| (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"))
(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)
(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
(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
(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~%")
(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)))))
projects / sbcl.git / blobdiff