X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=793161be81f768b0e7e25364f3e49a45ee8f1fd4;hb=273757631306c5d5c36f3aa7fed496a6d5c5f35e;hp=cbf5ce6a34cbe1226bb1c88f817facacbbdebd2f;hpb=828bcd9589641a560e01c2f2bc9134a0aaacd552;p=sbcl.git

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index cbf5ce6..793161b 100644
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -13,15 +13,45 @@
 
 (in-package "SB-THREAD") ; this is white-box testing, really
 
+(use-package :test-util)
+(use-package "ASSERTOID")
+
+(setf sb-unix::*on-dangerous-select* :error)
+
+(defun wait-for-threads (threads)
+  (mapc (lambda (thread) (sb-thread:join-thread thread :default nil)) threads)
+  (assert (not (some #'sb-thread:thread-alive-p threads))))
+
+(assert (eql 1 (length (list-all-threads))))
+
+(assert (eq *current-thread*
+            (find (thread-name *current-thread*) (list-all-threads)
+                  :key #'thread-name :test #'equal)))
+
+(assert (thread-alive-p *current-thread*))
+
+(let ((a 0))
+  (interrupt-thread *current-thread* (lambda () (setq a 1)))
+  (assert (eql a 1)))
+
+(let ((spinlock (make-spinlock)))
+  (with-spinlock (spinlock)))
+
+(let ((mutex (make-mutex)))
+  (with-mutex (mutex)
+    mutex))
+
+#-sb-thread (sb-ext:quit :unix-status 104)
+
 ;;; compare-and-swap
 
 (defmacro defincf (name accessor &rest args)
   `(defun ,name (x)
      (let* ((old (,accessor x ,@args))
-	 (new (1+ old)))
+         (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 (1+ old)))
     new)))
 
 (defstruct cas-struct (slot 0))
@@ -38,62 +68,33 @@
      (defun ,name (n)
        (declare (fixnum n))
        (let* ((x ,init)
-	      (run nil)
-	      (threads
-	       (loop repeat 10
-		     collect (sb-thread:make-thread 
-			      (lambda () 
-				(loop until run)
-				(loop repeat n do (,incf x)))))))
-	 (setf run t)
-	 (dolist (th threads) 
-	   (sb-thread:join-thread th))
-	 (assert (= (,op x) (* 10 n)))))
+              (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)
+                               (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)))
+                                                             (svref x 0)))
 (def-test-cas test-cas-svref/1 (vector nil 0) incf-svref/1 (lambda (x)
-							     (svref x 1)))
+                                                             (svref x 1)))
 (format t "~&compare-and-swap tests done~%")
 
-(use-package :test-util)
-(use-package "ASSERTOID")
-
-(setf sb-unix::*on-dangerous-select* :error)
-
-(defun wait-for-threads (threads)
-  (mapc (lambda (thread) (sb-thread:join-thread thread :default nil)) threads)
-  (assert (not (some #'sb-thread:thread-alive-p threads))))
-
-(assert (eql 1 (length (list-all-threads))))
-
-(assert (eq *current-thread*
-            (find (thread-name *current-thread*) (list-all-threads)
-                  :key #'thread-name :test #'equal)))
-
-(assert (thread-alive-p *current-thread*))
-
-(let ((a 0))
-  (interrupt-thread *current-thread* (lambda () (setq a 1)))
-  (assert (eql a 1)))
-
-(let ((spinlock (make-spinlock)))
-  (with-spinlock (spinlock)))
-
-(let ((mutex (make-mutex)))
-  (with-mutex (mutex)
-    mutex))
-
-#-sb-thread (sb-ext:quit :unix-status 104)
-
 (let ((old-threads (list-all-threads))
       (thread (make-thread (lambda ()
                              (assert (find *current-thread* *all-threads*))
@@ -156,7 +157,7 @@
                 "-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")
 
@@ -630,31 +631,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*