X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=dd2544c6d5a5e867ca69c57d050a6693021ac3a2;hb=da8cb4801a3ab35070f380e22aea3d260f9df8aa;hp=c285c81acca221e1332be9b3d25d65be488da495;hpb=402958f92506b9d3de852601b8c1ccb99b5ee558;p=sbcl.git

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index c285c81..dd2544c 100644
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -1,4 +1,3 @@
-
 ;;;; miscellaneous tests of thread stuff
 
 ;;;; This software is part of the SBCL system. See the README file for
@@ -15,9 +14,13 @@
 (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)
-  (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
+  (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))))
 
@@ -51,6 +54,19 @@
   (sleep 3)
   (assert (not (thread-alive-p thread))))
 
+(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))
+  (raises-error? (join-thread (make-thread (lambda () (sb-ext:quit))))))
+
+(with-test (:name '(:join-thread :multiple-values))
+  (assert (equal '(1 2 3)
+                 (multiple-value-list
+                  (join-thread (make-thread (lambda () (values 1 2 3))))))))
+
 ;;; We had appalling scaling properties for a while.  Make sure they
 ;;; don't reappear.
 (defun scaling-test (function &optional (nthreads 5))
@@ -83,13 +99,15 @@
   (format o "void loop_forever() { while(1) ; }~%"))
 (sb-ext:run-program
  #-sunos "cc" #+sunos "gcc"
- (or #+(or linux freebsd sunos) '("-shared" "-o" "threads-foreign.so" "threads-foreign.c")
-     #+darwin '("-dynamiclib" "-o" "threads-foreign.so" "threads-foreign.c")
+ (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-alien:load-shared-object "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"))
@@ -111,16 +129,35 @@
       (assert (ours-p (mutex-value l)) nil "5"))
     (assert (eql (mutex-value l) nil) nil "6")))
 
+(labels ((ours-p (value)
+           (eq *current-thread* value)))
+  (let ((l (make-spinlock :name "rec")))
+    (assert (eql (spinlock-value l) nil) nil "1")
+    (with-recursive-spinlock (l)
+      (assert (ours-p (spinlock-value l)) nil "3")
+      (with-recursive-spinlock (l)
+        (assert (ours-p (spinlock-value l)) nil "4"))
+      (assert (ours-p (spinlock-value l)) nil "5"))
+    (assert (eql (spinlock-value l) nil) nil "6")))
+
 (with-test (:name (:mutex :nesting-mutex-and-recursive-lock))
   (let ((l (make-mutex :name "a mutex")))
     (with-mutex (l)
       (with-recursive-lock (l)))))
 
+(with-test (:name (:spinlock :nesting-spinlock-and-recursive-spinlock))
+  (let ((l (make-spinlock :name "a spinlock")))
+    (with-spinlock (l)
+      (with-recursive-spinlock (l)))))
+
 (let ((l (make-spinlock :name "spinlock")))
-  (assert (eql (spinlock-value l) 0) nil "1")
+  (assert (eql (spinlock-value l) nil) ((spinlock-value l))
+          "spinlock not free (1)")
   (with-spinlock (l)
-    (assert (eql (spinlock-value l) 1) nil "2"))
-  (assert (eql (spinlock-value l) 0) nil "3"))
+    (assert (eql (spinlock-value l) *current-thread*) ((spinlock-value l))
+            "spinlock not taken"))
+  (assert (eql (spinlock-value l) nil) ((spinlock-value l))
+          "spinlock not free (2)"))
 
 ;; test that SLEEP actually sleeps for at least the given time, even
 ;; if interrupted by another thread exiting/a gc/anything
@@ -318,7 +355,8 @@
                       (lambda ()
                         (princ ".") (force-output)
                         (assert (thread-alive-p *current-thread*))
-                        (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
+                        (assert
+                         (not (logbitp 0 SB-KERNEL:*PSEUDO-ATOMIC-BITS*))))))
   (terminate-thread c)
   (wait-for-threads (list c)))
 
@@ -418,7 +456,9 @@
               (force-output)
               (sb-ext:quit :unix-status 1)))))))
 
-(let* ((nanosleep-errno (progn
+;; (nanosleep -1 0) does not fail on FreeBSD
+(let* (#-freebsd
+       (nanosleep-errno (progn
                           (sb-unix:nanosleep -1 0)
                           (sb-unix::get-errno)))
        (open-errno (progn
@@ -427,6 +467,7 @@
                      (sb-unix::get-errno)))
        (threads
         (list
+         #-freebsd
          (exercise-syscall (lambda () (sb-unix:nanosleep -1 0)) nanosleep-errno)
          (exercise-syscall (lambda () (open "no-such-file"
                                             :if-does-not-exist nil))
@@ -450,6 +491,7 @@
 
 (format t "~&thread startup sigmask test done~%")
 
+;; FIXME: What is this supposed to test?
 (sb-debug::enable-debugger)
 (let* ((main-thread *current-thread*)
        (interruptor-thread
@@ -457,7 +499,8 @@
                        (sleep 2)
                        (interrupt-thread main-thread #'break)
                        (sleep 2)
-                       (interrupt-thread main-thread #'continue)))))
+                       (interrupt-thread main-thread #'continue))
+                     :name "interruptor")))
   (with-session-lock (*session*)
     (sleep 3))
   (loop while (thread-alive-p interruptor-thread)))
@@ -609,11 +652,176 @@
               (force-output)
               (condition-broadcast queue)))))
 
+(format t "waitqueue wakeup tests done~%")
+
 (with-test (:name (:mutex :finalization))
   (let ((a nil))
     (dotimes (i 500000)
       (setf a (make-mutex)))))
 
-
-
-
+(format t "mutex finalization test done~%")
+
+;;; Check that INFO is thread-safe, at least when we're just doing reads.
+
+(let* ((symbols (loop repeat 10000 collect (gensym)))
+       (functions (loop for (symbol . rest) on symbols
+                        for next = (car rest)
+                        for fun = (let ((next next))
+                                    (lambda (n)
+                                      (if next
+                                          (funcall next (1- n))
+                                          n)))
+                        do (setf (symbol-function symbol) fun)
+                        collect fun)))
+  (defun infodb-test ()
+    (funcall (car functions) 9999)))
+
+(with-test (:name (:infodb :read))
+  (let* ((ok t)
+         (threads (loop for i from 0 to 10
+                        collect (sb-thread:make-thread
+                                 (lambda ()
+                                   (dotimes (j 100)
+                                     (write-char #\-)
+                                     (finish-output)
+                                     (let ((n (infodb-test)))
+                                       (unless (zerop n)
+                                         (setf ok nil)
+                                         (format t "N != 0 (~A)~%" n)
+                                         (sb-ext:quit)))))))))
+    (wait-for-threads threads)
+    (assert ok)))
+
+(format t "infodb test done~%")
+
+(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
+  ;; thread-safe for only doing FIND-SYMBOL, and while printing
+  ;; backtraces a loot of symbol lookups need to be done due to
+  ;; *PRINT-ESCAPE*.
+  (let* ((threads (loop repeat 10
+                        collect (sb-thread:make-thread
+                                 (lambda ()
+                                   (dotimes (i 1000)
+                                     (with-output-to-string (*debug-io*)
+                                       (sb-debug::backtrace 10))))))))
+    (wait-for-threads threads)))
+
+(format t "backtrace test done~%")
+
+(format t "~&starting gc deadlock test: WARNING: THIS TEST WILL HANG ON FAILURE!~%")
+
+(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
+  ;; to catch that typically well before the 1500th iteration.
+  (loop
+     with i = 0
+     with n = 3000
+     while (< i n)
+     do
+       (incf i)
+       (when (zerop (mod i 100))
+         (write-char #\.)
+         (force-output))
+       (handler-case
+           (if (oddp i)
+               (sb-thread:make-thread
+                (lambda ()
+                  (sleep (random 0.001)))
+                :name (list :sleep i))
+               (sb-thread:make-thread
+                (lambda ()
+                  ;; KLUDGE: what we are doing here is explicit,
+                  ;; 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-session-lock (sb-thread::*session*)
+                      (sb-ext:gc))))
+                :name (list :gc i)))
+         (error (e)
+           (format t "~%error creating thread ~D: ~A -- backing off for retry~%" i e)
+           (sleep 0.1)
+           (incf i)))))
+
+(format t "~&gc deadlock test done~%")
+
+(let ((count (make-array 8 :initial-element 0)))
+  (defun closure-one ()
+    (declare (optimize safety))
+    (values (incf (aref count 0)) (incf (aref count 1))
+            (incf (aref count 2)) (incf (aref count 3))
+            (incf (aref count 4)) (incf (aref count 5))
+            (incf (aref count 6)) (incf (aref count 7))))
+  (defun no-optimizing-away-closure-one ()
+    (setf count (make-array 8 :initial-element 0))))
+
+(defstruct box
+  (count 0))
+
+(let ((one (make-box))
+      (two (make-box))
+      (three (make-box)))
+  (defun closure-two ()
+    (declare (optimize safety))
+    (values (incf (box-count one)) (incf (box-count two)) (incf (box-count three))))
+  (defun no-optimizing-away-closure-two ()
+    (setf one (make-box)
+          two (make-box)
+          three (make-box))))
+
+(with-test (:name (:funcallable-instances))
+  ;; the funcallable-instance implementation used not to be threadsafe
+  ;; against setting the funcallable-instance function to a closure
+  ;; (because the code and lexenv were set separately).
+  (let ((fun (sb-kernel:%make-funcallable-instance 0))
+        (condition nil))
+    (setf (sb-kernel:funcallable-instance-fun fun) #'closure-one)
+    (flet ((changer ()
+             (loop (setf (sb-kernel:funcallable-instance-fun fun) #'closure-one)
+                   (setf (sb-kernel:funcallable-instance-fun fun) #'closure-two)))
+           (test ()
+             (handler-case (loop (funcall fun))
+               (serious-condition (c) (setf condition c)))))
+      (let ((changer (make-thread #'changer))
+            (test (make-thread #'test)))
+        (handler-case
+            (progn
+              ;; The two closures above are fairly carefully crafted
+              ;; so that if given the wrong lexenv they will tend to
+              ;; do some serious damage, but it is of course difficult
+              ;; to predict where the various bits and pieces will be
+              ;; allocated.  Five seconds failed fairly reliably on
+              ;; both my x86 and x86-64 systems.  -- CSR, 2006-09-27.
+              (sb-ext:with-timeout 5
+                (wait-for-threads (list test)))
+              (error "~@<test thread got condition:~2I~_~A~@:>" condition))
+          (sb-ext:timeout ()
+            (terminate-thread changer)
+            (terminate-thread test)
+            (wait-for-threads (list changer test))))))))
+
+(format t "~&funcallable-instance test done~%")
+
+(defun random-type (n)
+  `(integer ,(random n) ,(+ n (random n))))
+
+(defun subtypep-hash-cache-test ()
+  (dotimes (i 10000)
+    (let ((type1 (random-type 500))
+          (type2 (random-type 500)))
+      (let ((a (subtypep type1 type2)))
+        (dotimes (i 100)
+          (assert (eq (subtypep type1 type2) a))))))
+  (format t "ok~%")
+  (force-output))
+
+(with-test (:name '(:hash-cache :subtypep))
+  (dotimes (i 10)
+    (sb-thread:make-thread #'subtypep-hash-cache-test)))
+
+(format t "hash-cache tests done~%")