X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=3eb0fe0a74c8fea0578f3b0fd54216dae8339e4c;hb=c553e4be6da2d18f0827f190589c88e837b8b8a6;hp=eb4fe5a1b71a7c461777acdfdcdbbf05178758a3;hpb=c548f73e8dd676d6ec4576eba6ab661a5061bdfe;p=sbcl.git

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index eb4fe5a..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,100 @@
   (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)
+  `(defun ,name (x)
+     (let* ((old (,accessor x ,@args))
+         (new (1+ old)))
+    (loop until (eq old (sb-ext:compare-and-swap (,accessor x ,@args) old new))
+       do (setf old (,accessor x ,@args)
+                new (1+ old)))
+    new)))
+
+(defstruct cas-struct (slot 0))
+
+(defincf incf-car car)
+(defincf incf-cdr cdr)
+(defincf incf-slot cas-struct-slot)
+(defincf incf-symbol-value symbol-value)
+(defincf incf-svref/1 svref 1)
+(defincf incf-svref/0 svref 0)
+
+(defmacro def-test-cas (name init incf op)
+  `(progn
+     (defun ,name (n)
+       (declare (fixnum n))
+       (let* ((x ,init)
+              (run nil)
+              (threads
+               (loop repeat 10
+                     collect (sb-thread:make-thread
+                              (lambda ()
+                                (loop until run
+                                   do (sb-thread:thread-yield))
+                                (loop repeat n do (,incf x)))))))
+         (setf run t)
+         (dolist (th threads)
+           (sb-thread:join-thread th))
+         (assert (= (,op x) (* 10 n)))))
+     (,name 200000)))
+
+(def-test-cas test-cas-car (cons 0 nil) incf-car car)
+(def-test-cas test-cas-cdr (cons nil 0) incf-cdr cdr)
+(def-test-cas test-cas-slot (make-cas-struct) incf-slot cas-struct-slot)
+(def-test-cas test-cas-value (let ((x '.x.))
+                               (set x 0)
+                               x)
+  incf-symbol-value symbol-value)
+(def-test-cas test-cas-svref/0 (vector 0 nil) incf-svref/0 (lambda (x)
+                                                             (svref x 0)))
+(def-test-cas test-cas-svref/1 (vector nil 0) incf-svref/1 (lambda (x)
+                                                             (svref x 1)))
+(format t "~&compare-and-swap tests done~%")
+
 (let ((old-threads (list-all-threads))
       (thread (make-thread (lambda ()
                              (assert (find *current-thread* *all-threads*))
@@ -60,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)
@@ -105,9 +199,9 @@
                 "-dynamiclib" "-o" "threads-foreign.so" "threads-foreign.c")
      (error "Missing shared library compilation options for this platform"))
  :search t)
-(sb-alien:load-shared-object "threads-foreign.so")
+(sb-alien:load-shared-object (truename "threads-foreign.so"))
 (sb-alien:define-alien-routine loop-forever sb-alien:void)
-
+(delete-file "threads-foreign.c")
 
 ;;; elementary "can we get a lock and release it again"
 (let ((l (make-mutex :name "foo"))
@@ -362,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)
@@ -377,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)
@@ -497,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")))
@@ -579,31 +714,153 @@
 
 (format t "~&binding test done~%")
 
-;; Try to corrupt the NEXT-VECTOR. Operations on a hash table with a
-;; cyclic NEXT-VECTOR can loop endlessly in a WITHOUT-GCING form
-;; causing the next gc hang SBCL.
-(with-test (:name (:hash-table-thread-safety))
+;;; HASH TABLES
+
+(defvar *errors* nil)
+
+(defun oops (e)
+  (setf *errors* e)
+  (format t "~&oops: ~A in ~S~%" e *current-thread*)
+  (sb-debug:backtrace)
+  (catch 'done))
+
+(with-test (:name (:unsynchronized-hash-table))
+  ;; 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.
   (let* ((hash (make-hash-table))
+         (*errors* nil)
          (threads (list (sb-thread:make-thread
                          (lambda ()
-                           (loop
-                            ;;(princ "1") (force-output)
-                            (setf (gethash (random 100) hash) 'h))))
+                           (catch 'done
+                             (handler-bind ((serious-condition 'oops))
+                               (loop
+                                 ;;(princ "1") (force-output)
+                                 (setf (gethash (random 100) hash) 'h)))))
+                         :name "writer")
                         (sb-thread:make-thread
                          (lambda ()
-                           (loop
-                            ;;(princ "2") (force-output)
-                            (remhash (random 100) hash))))
+                           (catch 'done
+                             (handler-bind ((serious-condition 'oops))
+                               (loop
+                                 ;;(princ "2") (force-output)
+                                 (remhash (random 100) hash)))))
+                         :name "reader")
                         (sb-thread:make-thread
                          (lambda ()
-                           (loop
-                            (sleep (random 1.0))
-                            (sb-ext:gc :full t)))))))
+                           (catch 'done
+                             (handler-bind ((serious-condition 'oops))
+                               (loop
+                                 (sleep (random 1.0))
+                                 (sb-ext:gc :full t)))))
+                         :name "collector"))))
     (unwind-protect
-         (sleep 5)
+         (sleep 10)
       (mapc #'sb-thread:terminate-thread threads))))
 
-(format t "~&hash table test done~%")
+(format t "~&unsynchronized hash table test done~%")
+
+(with-test (:name (:synchronized-hash-table))
+  (let* ((hash (make-hash-table :synchronized t))
+         (*errors* nil)
+         (threads (list (sb-thread:make-thread
+                         (lambda ()
+                           (catch 'done
+                             (handler-bind ((serious-condition 'oops))
+                               (loop
+                                 ;;(princ "1") (force-output)
+                                 (setf (gethash (random 100) hash) 'h)))))
+                         :name "writer")
+                        (sb-thread:make-thread
+                         (lambda ()
+                           (catch 'done
+                             (handler-bind ((serious-condition 'oops))
+                               (loop
+                                 ;;(princ "2") (force-output)
+                                 (remhash (random 100) hash)))))
+                         :name "reader")
+                        (sb-thread:make-thread
+                         (lambda ()
+                           (catch 'done
+                             (handler-bind ((serious-condition 'oops))
+                               (loop
+                                 (sleep (random 1.0))
+                                 (sb-ext:gc :full t)))))
+                         :name "collector"))))
+    (unwind-protect
+         (sleep 10)
+      (mapc #'sb-thread:terminate-thread threads))
+    (assert (not *errors*))))
+
+(format t "~&synchronized hash table test done~%")
+
+(with-test (:name (:hash-table-parallel-readers))
+  (let ((hash (make-hash-table))
+        (*errors* nil))
+    (loop repeat 50
+          do (setf (gethash (random 100) hash) 'xxx))
+    (let ((threads (list (sb-thread:make-thread
+                          (lambda ()
+                            (catch 'done
+                              (handler-bind ((serious-condition 'oops))
+                                (loop
+                                      until (eq t (gethash (random 100) hash))))))
+                          :name "reader 1")
+                         (sb-thread:make-thread
+                          (lambda ()
+                            (catch 'done
+                              (handler-bind ((serious-condition 'oops))
+                                (loop
+                                      until (eq t (gethash (random 100) hash))))))
+                          :name "reader 2")
+                         (sb-thread:make-thread
+                          (lambda ()
+                            (catch 'done
+                              (handler-bind ((serious-condition 'oops))
+                                (loop
+                                      until (eq t (gethash (random 100) hash))))))
+                          :name "reader 3")
+                         (sb-thread:make-thread
+                          (lambda ()
+                            (catch 'done
+                              (handler-bind ((serious-condition 'oops))
+                               (loop
+                                 (sleep (random 1.0))
+                                 (sb-ext:gc :full t)))))
+                          :name "collector"))))
+      (unwind-protect
+           (sleep 10)
+        (mapc #'sb-thread:terminate-thread threads))
+      (assert (not *errors*)))))
+
+(format t "~&multiple reader hash table test done~%")
+
+(with-test (:name (:hash-table-single-accessor-parallel-gc))
+  (let ((hash (make-hash-table))
+        (*errors* nil))
+    (let ((threads (list (sb-thread:make-thread
+                          (lambda ()
+                            (handler-bind ((serious-condition 'oops))
+                              (loop
+                                (let ((n (random 100)))
+                                  (if (gethash n hash)
+                                      (remhash n hash)
+                                      (setf (gethash n hash) 'h))))))
+                          :name "accessor")
+                         (sb-thread:make-thread
+                          (lambda ()
+                            (handler-bind ((serious-condition 'oops))
+                              (loop
+                                (sleep (random 1.0))
+                                (sb-ext:gc :full t))))
+                          :name "collector"))))
+      (unwind-protect
+           (sleep 10)
+        (mapc #'sb-thread:terminate-thread threads))
+      (assert (not *errors*)))))
+
+(format t "~&single accessor hash table test~%")
+
 #|  ;; a cll post from eric marsden
 | (defun crash ()
 |   (setq *debugger-hook*
@@ -617,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"))
@@ -739,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)))
@@ -823,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~%")