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

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index 48bf07e..c285c81 100644
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -1,3 +1,4 @@
+
 ;;;; miscellaneous tests of thread stuff
 
 ;;;; This software is part of the SBCL system. See the README file for
@@ -13,6 +14,11 @@
 
 (in-package "SB-THREAD") ; this is white-box testing, really
 
+(use-package :test-util)
+
+(defun wait-for-threads (threads)
+  (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
+
 (assert (eql 1 (length (list-all-threads))))
 
 (assert (eq *current-thread*
@@ -54,7 +60,8 @@
     ;; Start NTHREADS idle threads.
     (dotimes (i nthreads)
       (sb-thread:make-thread (lambda ()
-                               (sb-thread:condition-wait queue mutex)
+                               (with-mutex (mutex)
+                                 (sb-thread:condition-wait queue mutex))
                                (sb-ext:quit))))
     (let ((start-time (get-internal-run-time)))
       (funcall function)
@@ -75,8 +82,9 @@
 (with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
   (format o "void loop_forever() { while(1) ; }~%"))
 (sb-ext:run-program
- "cc"
- (or #+linux '("-shared" "-o" "threads-foreign.so" "threads-foreign.c")
+ #-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")
      (error "Missing shared library compilation options for this platform"))
  :search t)
 (sb-alien:load-shared-object "threads-foreign.so")
@@ -93,8 +101,7 @@
   (assert (eql (mutex-value l) nil) nil "5"))
 
 (labels ((ours-p (value)
-           (sb-vm:control-stack-pointer-valid-p
-            (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value)))))
+           (eq *current-thread* value)))
   (let ((l (make-mutex :name "rec")))
     (assert (eql (mutex-value l) nil) nil "1")
     (sb-thread:with-recursive-lock (l)
@@ -104,11 +111,15 @@
       (assert (ours-p (mutex-value l)) nil "5"))
     (assert (eql (mutex-value l) nil) nil "6")))
 
-(let ((l (make-spinlock :name "spinlock"))
-      (p *current-thread*))
+(with-test (:name (:mutex :nesting-mutex-and-recursive-lock))
+  (let ((l (make-mutex :name "a mutex")))
+    (with-mutex (l)
+      (with-recursive-lock (l)))))
+
+(let ((l (make-spinlock :name "spinlock")))
   (assert (eql (spinlock-value l) 0) nil "1")
   (with-spinlock (l)
-    (assert (eql (spinlock-value l) p) nil "2"))
+    (assert (eql (spinlock-value l) 1) nil "2"))
   (assert (eql (spinlock-value l) 0) nil "3"))
 
 ;; test that SLEEP actually sleeps for at least the given time, even
@@ -145,8 +156,7 @@
 (let ((queue (make-waitqueue :name "queue"))
       (lock (make-mutex :name "lock")))
   (labels ((ours-p (value)
-             (sb-vm:control-stack-pointer-valid-p
-              (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value))))
+             (eq *current-thread* value))
            (in-new-thread ()
              (with-recursive-lock (lock)
                (assert (ours-p (mutex-value lock)))
@@ -170,13 +180,72 @@
              (let ((me *current-thread*))
                (dotimes (i 100)
                  (with-mutex (mutex)
-                   (sleep .1)
+                   (sleep .03)
                    (assert (eql (mutex-value mutex) me)))
                  (assert (not (eql (mutex-value mutex) me))))
                (format t "done ~A~%" *current-thread*))))
     (let ((kid1 (make-thread #'run))
           (kid2 (make-thread #'run)))
-      (format t "contention ~A ~A~%" kid1 kid2))))
+      (format t "contention ~A ~A~%" kid1 kid2)
+      (wait-for-threads (list kid1 kid2)))))
+
+;;; semaphores
+
+(defmacro raises-timeout-p (&body body)
+  `(handler-case (progn (progn ,@body) nil)
+    (sb-ext:timeout () t)))
+
+(with-test (:name (:semaphore :wait-forever))
+  (let ((sem (make-semaphore :count 0)))
+    (assert (raises-timeout-p
+              (sb-ext:with-timeout 0.1
+                (wait-on-semaphore sem))))))
+
+(with-test (:name (:semaphore :initial-count))
+  (let ((sem (make-semaphore :count 1)))
+    (sb-ext:with-timeout 0.1
+      (wait-on-semaphore sem))))
+
+(with-test (:name (:semaphore :wait-then-signal))
+  (let ((sem (make-semaphore))
+        (signalled-p nil))
+    (make-thread (lambda ()
+                   (sleep 0.1)
+                   (setq signalled-p t)
+                   (signal-semaphore sem)))
+    (wait-on-semaphore sem)
+    (assert signalled-p)))
+
+(with-test (:name (:semaphore :signal-then-wait))
+  (let ((sem (make-semaphore))
+        (signalled-p nil))
+    (make-thread (lambda ()
+                   (signal-semaphore sem)
+                   (setq signalled-p t)))
+    (loop until signalled-p)
+    (wait-on-semaphore sem)
+    (assert signalled-p)))
+
+(with-test (:name (:semaphore :multiple-signals))
+  (let* ((sem (make-semaphore :count 5))
+         (threads (loop repeat 20
+                        collect (make-thread (lambda ()
+                                               (wait-on-semaphore sem))))))
+    (flet ((count-live-threads ()
+             (count-if #'thread-alive-p threads)))
+      (sleep 0.5)
+      (assert (= 15 (count-live-threads)))
+      (signal-semaphore sem 10)
+      (sleep 0.5)
+      (assert (= 5 (count-live-threads)))
+      (signal-semaphore sem 3)
+      (sleep 0.5)
+      (assert (= 2 (count-live-threads)))
+      (signal-semaphore sem 4)
+      (sleep 0.5)
+      (assert (= 0 (count-live-threads))))))
+
+(format t "~&semaphore tests done~%")
 
 (defun test-interrupt (function-to-interrupt &optional quit-p)
   (let ((child  (make-thread function-to-interrupt)))
@@ -199,7 +268,8 @@
 (test-interrupt #'loop-forever :quit)
 
 (let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
-  (terminate-thread child))
+  (terminate-thread child)
+  (wait-for-threads (list child)))
 
 (let ((lock (make-mutex :name "loctite"))
       child)
@@ -214,7 +284,8 @@
     (sleep 5)
     (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock))))
     (format t "parent releasing lock~%"))
-  (terminate-thread child))
+  (terminate-thread child)
+  (wait-for-threads (list child)))
 
 (format t "~&locking test done~%")
 
@@ -230,11 +301,10 @@
                           (sleep (random 0.1d0))
                           (princ ".")
                           (force-output)
-                          (sb-thread:interrupt-thread
-                           thread
-                           (lambda ()))))))))
-      (loop while (some #'thread-alive-p killers) do (sleep 0.1))
-      (sb-thread:terminate-thread thread)))
+                          (sb-thread:interrupt-thread thread (lambda ()))))))))
+      (wait-for-threads killers)
+      (sb-thread:terminate-thread thread)
+      (wait-for-threads (list thread))))
   (sb-ext:gc :full t))
 
 (format t "~&multi interrupt test done~%")
@@ -242,15 +312,15 @@
 (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
-  (format t "new thread ~A~%" c)
   (dotimes (i 100)
     (sleep (random 0.1d0))
     (interrupt-thread c
                       (lambda ()
                         (princ ".") (force-output)
-                        (assert (eq (thread-state *current-thread*) :running))
+                        (assert (thread-alive-p *current-thread*))
                         (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
-  (terminate-thread c))
+  (terminate-thread c)
+  (wait-for-threads (list c)))
 
 (format t "~&interrupt test done~%")
 
@@ -278,9 +348,9 @@
     (dotimes (i 100)
       (sleep (random 0.1d0))
       (interrupt-thread c func))
-    (format t "~&waiting for interrupts to arrive~%")
     (loop until (= *interrupt-count* 100) do (sleep 0.1))
-    (terminate-thread c)))
+    (terminate-thread c)
+    (wait-for-threads (list c))))
 
 (format t "~&interrupt count test done~%")
 
@@ -393,6 +463,104 @@
   (loop while (thread-alive-p interruptor-thread)))
 
 (format t "~&session lock test done~%")
+
+(loop repeat 20 do
+      (wait-for-threads
+       (loop for i below 100 collect
+             (sb-thread:make-thread (lambda ())))))
+
+(format t "~&creation test done~%")
+
+;; interrupt handlers are per-thread with pthreads, make sure the
+;; handler installed in one thread is global
+(sb-thread:make-thread
+ (lambda ()
+   (sb-ext:run-program "sleep" '("1") :search t :wait nil)))
+
+;;;; Binding stack safety
+
+(defparameter *x* nil)
+(defparameter *n-gcs-requested* 0)
+(defparameter *n-gcs-done* 0)
+
+(let ((counter 0))
+  (defun make-something-big ()
+    (let ((x (make-string 32000)))
+      (incf counter)
+      (let ((counter counter))
+        (sb-ext:finalize x (lambda () (format t " ~S" counter)
+                                   (force-output)))))))
+
+(defmacro wait-for-gc ()
+  `(progn
+     (incf *n-gcs-requested*)
+     (loop while (< *n-gcs-done* *n-gcs-requested*))))
+
+(defun send-gc ()
+  (loop until (< *n-gcs-done* *n-gcs-requested*))
+  (format t "G")
+  (force-output)
+  (sb-ext:gc)
+  (incf *n-gcs-done*))
+
+(defun exercise-binding ()
+  (loop
+   (let ((*x* (make-something-big)))
+     (let ((*x* 42))
+       ;; at this point the binding stack looks like this:
+       ;; NO-TLS-VALUE-MARKER, *x*, SOMETHING, *x*
+       t))
+   (wait-for-gc)
+   ;; sig_stop_for_gc_handler binds FREE_INTERRUPT_CONTEXT_INDEX. By
+   ;; now SOMETHING is gc'ed and the binding stack looks like this: 0,
+   ;; 0, SOMETHING, 0 (because the symbol slots are zeroed on
+   ;; unbinding but values are not).
+   (let ((*x* nil))
+     ;; bump bsp as if a BIND had just started
+     (incf sb-vm::*binding-stack-pointer* 2)
+     (wait-for-gc)
+     (decf sb-vm::*binding-stack-pointer* 2))))
+
+(with-test (:name (:binding-stack-gc-safety))
+  (let (threads)
+    (unwind-protect
+         (progn
+           (push (sb-thread:make-thread #'exercise-binding) threads)
+           (push (sb-thread:make-thread (lambda ()
+                                          (loop
+                                           (sleep 0.1)
+                                           (send-gc))))
+                 threads)
+           (sleep 4))
+      (mapc #'sb-thread:terminate-thread threads))))
+
+(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))
+  (let* ((hash (make-hash-table))
+         (threads (list (sb-thread:make-thread
+                         (lambda ()
+                           (loop
+                            ;;(princ "1") (force-output)
+                            (setf (gethash (random 100) hash) 'h))))
+                        (sb-thread:make-thread
+                         (lambda ()
+                           (loop
+                            ;;(princ "2") (force-output)
+                            (remhash (random 100) hash))))
+                        (sb-thread:make-thread
+                         (lambda ()
+                           (loop
+                            (sleep (random 1.0))
+                            (sb-ext:gc :full t)))))))
+    (unwind-protect
+         (sleep 5)
+      (mapc #'sb-thread:terminate-thread threads))))
+
+(format t "~&hash table test done~%")
 #|  ;; a cll post from eric marsden
 | (defun crash ()
 |   (setq *debugger-hook*
@@ -406,8 +574,46 @@
 |     (mp:make-process #'roomy)))
 |#
 
-;; give the other thread time to die before we leave, otherwise the
-;; overall exit status is 0, not 104
-(sleep 2)
+(with-test (:name (:condition-variable :notify-multiple))
+  (flet ((tester (notify-fun)
+           (let ((queue (make-waitqueue :name "queue"))
+                 (lock (make-mutex :name "lock"))
+                 (data nil))
+             (labels ((test (x)
+                        (loop
+                           (with-mutex (lock)
+                             (format t "condition-wait ~a~%" x)
+                             (force-output)
+                             (condition-wait queue lock)
+                             (format t "woke up ~a~%" x)
+                             (force-output)
+                             (push x data)))))
+               (let ((threads (loop for x from 1 to 10
+                                    collect
+                                    (let ((x x))
+                                      (sb-thread:make-thread (lambda ()
+                                                               (test x)))))))
+                 (sleep 5)
+                 (with-mutex (lock)
+                   (funcall notify-fun queue))
+                 (sleep 5)
+                 (mapcar #'terminate-thread threads)
+                 ;; Check that all threads woke up at least once
+                 (assert (= (length (remove-duplicates data)) 10)))))))
+    (tester (lambda (queue)
+              (format t "~&(condition-notify queue 10)~%")
+              (force-output)
+              (condition-notify queue 10)))
+    (tester (lambda (queue)
+              (format t "~&(condition-broadcast queue)~%")
+              (force-output)
+              (condition-broadcast queue)))))
+
+(with-test (:name (:mutex :finalization))
+  (let ((a nil))
+    (dotimes (i 500000)
+      (setf a (make-mutex)))))
+
+
+
 
-(sb-ext:quit :unix-status 104)