X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=068d68b99a5c02525d88f41c7e0fb7e5c078d79c;hb=5759fa78f2289c7e891aaded2a54e069b8bdac01;hp=c0feefe3d25298b7a1b2811cc82c846fa6a6bfa7;hpb=fb9c34275389e23f32d80954ab4848fac48936d9;p=sbcl.git

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index c0feefe..068d68b 100644
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -6,98 +6,334 @@
 ;;;; While most of SBCL is derived from the CMU CL system, the test
 ;;;; files (like this one) were written from scratch after the fork
 ;;;; from CMU CL.
-;;; 
+;;;
 ;;;; This software is in the public domain and is provided with
 ;;;; absoluely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 
-#-sb-thread (quit :unix-status 104)
-
 (in-package "SB-THREAD") ; this is white-box testing, really
 
+;;; 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)
+                                (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~%")
+
+(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*))
+                             (sleep 2))))
+      (new-threads (list-all-threads)))
+  (assert (thread-alive-p thread))
+  (assert (eq thread (first new-threads)))
+  (assert (= (1+ (length old-threads)) (length new-threads)))
+  (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))
+  "Execute FUNCTION with NTHREADS lurking to slow it down."
+  (let ((queue (sb-thread:make-waitqueue))
+        (mutex (sb-thread:make-mutex)))
+    ;; Start NTHREADS idle threads.
+    (dotimes (i nthreads)
+      (sb-thread:make-thread (lambda ()
+                               (with-mutex (mutex)
+                                 (sb-thread:condition-wait queue mutex))
+                               (sb-ext:quit))))
+    (let ((start-time (get-internal-run-time)))
+      (funcall function)
+      (prog1 (- (get-internal-run-time) start-time)
+        (sb-thread:condition-broadcast queue)))))
+(defun fact (n)
+  "A function that does work with the CPU."
+  (if (zerop n) 1 (* n (fact (1- n)))))
+(let ((work (lambda () (fact 15000))))
+  (let ((zero (scaling-test work 0))
+        (four (scaling-test work 4)))
+    ;; a slightly weak assertion, but good enough for starters.
+    (assert (< four (* 1.5 zero)))))
+
 ;;; For one of the interupt-thread tests, we want a foreign function
 ;;; that does not make syscalls
 
 (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")
+(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-alien:load-1-foreign "threads-foreign.so")
+(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"))
-      (p (current-thread-id)))
+      (p *current-thread*))
   (assert (eql (mutex-value l) nil) nil "1")
-  (assert (eql (mutex-lock l) 0) nil "2")
   (sb-thread:get-mutex l)
   (assert (eql (mutex-value l) p) nil "3")
-  (assert (eql (mutex-lock l) 0) nil "4")
   (sb-thread:release-mutex l)
-  (assert (eql (mutex-value l) nil) nil "5")
-  (assert (eql (mutex-lock l) 0)  nil "6")
-  (describe l))
+  (assert (eql (mutex-value l) nil) nil "5"))
+
+(labels ((ours-p (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)
+      (assert (ours-p (mutex-value l)) nil "3")
+      (sb-thread:with-recursive-lock (l)
+        (assert (ours-p (mutex-value l)) nil "4"))
+      (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) nil) ((spinlock-value l))
+          "spinlock not free (1)")
+  (with-spinlock (l)
+    (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
+(let ((start-time (get-universal-time)))
+  (make-thread (lambda () (sleep 1) (sb-ext:gc :full t)))
+  (sleep 5)
+  (assert (>= (get-universal-time) (+ 5 start-time))))
+
 
 (let ((queue (make-waitqueue :name "queue"))
-      (lock (make-mutex :name "lock")))
+      (lock (make-mutex :name "lock"))
+      (n 0))
   (labels ((in-new-thread ()
-	     (with-mutex (lock)
-	       (assert (eql (mutex-value lock) (current-thread-id)))
-	       (format t "~A got mutex~%" (current-thread-id))
-	       ;; now drop it and sleep
-	       (condition-wait queue lock)
-	       ;; after waking we should have the lock again
-	       (assert (eql (mutex-value lock) (current-thread-id))))))
+             (with-mutex (lock)
+               (assert (eql (mutex-value lock) *current-thread*))
+               (format t "~A got mutex~%" *current-thread*)
+               ;; now drop it and sleep
+               (condition-wait queue lock)
+               ;; after waking we should have the lock again
+               (assert (eql (mutex-value lock) *current-thread*))
+               (assert (eql n 1))
+               (decf n))))
     (make-thread #'in-new-thread)
-    (sleep 2)				; give it  a chance to start
+    (sleep 2)                           ; give it  a chance to start
     ;; check the lock is free while it's asleep
-    (format t "parent thread ~A~%" (current-thread-id))
-    (assert (eql (mutex-value lock) nil))    
-    (assert (eql (mutex-lock lock) 0))
+    (format t "parent thread ~A~%" *current-thread*)
+    (assert (eql (mutex-value lock) nil))
     (with-mutex (lock)
+      (incf n)
       (condition-notify queue))
     (sleep 1)))
 
 (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))))
-	   (in-new-thread ()
-	     (with-recursive-lock (lock)
-	       (assert (ours-p (mutex-value lock)))
-	       (format t "~A got mutex~%" (mutex-value lock))
-	       ;; now drop it and sleep
-	       (condition-wait queue lock)
-	       ;; after waking we should have the lock again
-	       (format t "woken, ~A got mutex~%" (mutex-value lock))
-	       (assert (ours-p (mutex-value lock))))))
+             (eq *current-thread* value))
+           (in-new-thread ()
+             (with-recursive-lock (lock)
+               (assert (ours-p (mutex-value lock)))
+               (format t "~A got mutex~%" (mutex-value lock))
+               ;; now drop it and sleep
+               (condition-wait queue lock)
+               ;; after waking we should have the lock again
+               (format t "woken, ~A got mutex~%" (mutex-value lock))
+               (assert (ours-p (mutex-value lock))))))
     (make-thread #'in-new-thread)
-    (sleep 2)				; give it  a chance to start
+    (sleep 2)                           ; give it  a chance to start
     ;; check the lock is free while it's asleep
-    (format t "parent thread ~A~%" (current-thread-id))
-    (assert (eql (mutex-value lock) nil))    
-    (assert (eql (mutex-lock lock) 0))
+    (format t "parent thread ~A~%" *current-thread*)
+    (assert (eql (mutex-value lock) nil))
     (with-recursive-lock (lock)
       (condition-notify queue))
     (sleep 1)))
 
 (let ((mutex (make-mutex :name "contended")))
   (labels ((run ()
-	     (let ((me (current-thread-id)))
-	       (dotimes (i 100)
-		 (with-mutex (mutex)
-		   (sleep .1)
-		   (assert (eql (mutex-value mutex) me)))
-		 (assert (not (eql (mutex-value mutex) me))))
-	       (format t "done ~A~%" (current-thread-id)))))
+             (let ((me *current-thread*))
+               (dotimes (i 100)
+                 (with-mutex (mutex)
+                   (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))))
+          (kid2 (make-thread #'run)))
+      (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)))
@@ -105,73 +341,320 @@
     (sleep 2)
     (format t "interrupting child ~A~%" child)
     (interrupt-thread child
-		      (lambda ()
-			(format t "child pid ~A~%" (current-thread-id))
-			(when quit-p (sb-ext:quit))))
+                      (lambda ()
+                        (format t "child pid ~A~%" *current-thread*)
+                        (when quit-p (sb-ext:quit))))
     (sleep 1)
     child))
 
-;;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
-;;; (d) waiting on a lock, (e) some code which we hope is likely to be
-;;; in pseudo-atomic
+;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
+;; (d) waiting on a lock, (e) some code which we hope is likely to be
+;; in pseudo-atomic
 
 (let ((child (test-interrupt (lambda () (loop)))))  (terminate-thread child))
 
 (test-interrupt #'loop-forever :quit)
 
 (let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
-  ;; Interrupting a sleep form causes it to return early.  Welcome to Unix.
-  ;; Just to be sure our LOOP form works, let's check the child is still
-  ;; there
-  (assert (zerop (sb-unix:unix-kill child 0)))
-  (terminate-thread child))
-		
+  (terminate-thread child)
+  (wait-for-threads (list child)))
+
 (let ((lock (make-mutex :name "loctite"))
       child)
   (with-mutex (lock)
     (setf child (test-interrupt
-		 (lambda ()
-		   (with-mutex (lock)
-		     (assert (eql (mutex-value lock) (current-thread-id))))
-		   (assert (not (eql (mutex-value lock) (current-thread-id))))
-		   (sleep 60))))
+                 (lambda ()
+                   (with-mutex (lock)
+                     (assert (eql (mutex-value lock) *current-thread*)))
+                   (assert (not (eql (mutex-value lock) *current-thread*)))
+                   (sleep 10))))
     ;;hold onto lock for long enough that child can't get it immediately
-    (sleep 20)
+    (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~%")
 
 (defun alloc-stuff () (copy-list '(1 2 3 4 5)))
 
-(let ((c (test-interrupt (lambda () (loop (alloc-stuff))))))
+(progn
+  (let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff))))))
+    (let ((killers
+           (loop repeat 4 collect
+                 (sb-thread:make-thread
+                  (lambda ()
+                    (loop repeat 25 do
+                          (sleep (random 0.1d0))
+                          (princ ".")
+                          (force-output)
+                          (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~%")
+
+(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 1d0))
+    (sleep (random 0.1d0))
     (interrupt-thread c
-		      (lambda ()
-			(princ ".") (force-output)
-			(assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
-  (terminate-thread c))
+                      (lambda ()
+                        (princ ".") (force-output)
+                        (assert (thread-alive-p *current-thread*))
+                        (assert
+                         (not (logbitp 0 SB-KERNEL:*PSEUDO-ATOMIC-BITS*))))))
+  (terminate-thread c)
+  (wait-for-threads (list c)))
 
 (format t "~&interrupt test done~%")
 
+(defparameter *interrupt-count* 0)
+
+(declaim (notinline check-interrupt-count))
+(defun check-interrupt-count (i)
+  (declare (optimize (debug 1) (speed 1)))
+  ;; This used to lose if eflags were not restored after an interrupt.
+  (unless (typep i 'fixnum)
+    (error "!!!!!!!!!!!")))
+
+(let ((c (make-thread
+          (lambda ()
+            (handler-bind ((error #'(lambda (cond)
+                                      (princ cond)
+                                      (sb-debug:backtrace
+                                       most-positive-fixnum))))
+              (loop (check-interrupt-count *interrupt-count*)))))))
+  (let ((func (lambda ()
+                (princ ".")
+                (force-output)
+                (sb-impl::atomic-incf/symbol *interrupt-count*))))
+    (setq *interrupt-count* 0)
+    (dotimes (i 100)
+      (sleep (random 0.1d0))
+      (interrupt-thread c func))
+    (loop until (= *interrupt-count* 100) do (sleep 0.1))
+    (terminate-thread c)
+    (wait-for-threads (list c))))
+
+(format t "~&interrupt count test done~%")
+
 (let (a-done b-done)
   (make-thread (lambda ()
-		 (dotimes (i 100) 
-		   (sb-ext:gc) (princ "\\") (force-output) )
-		 (setf a-done t)))
+                 (dotimes (i 100)
+                   (sb-ext:gc) (princ "\\") (force-output))
+                 (setf a-done t)))
   (make-thread (lambda ()
-		 (dotimes (i 25) 
-		   (sb-ext:gc :full t)
-		   (princ "/") (force-output))
-		 (setf b-done t)))
+                 (dotimes (i 25)
+                   (sb-ext:gc :full t)
+                   (princ "/") (force-output))
+                 (setf b-done t)))
   (loop
    (when (and a-done b-done) (return))
    (sleep 1)))
+
+(terpri)
+
+(defun waste (&optional (n 100000))
+  (loop repeat n do (make-string 16384)))
+
+(loop for i below 100 do
+      (princ "!")
+      (force-output)
+      (sb-thread:make-thread
+       #'(lambda ()
+           (waste)))
+      (waste)
+      (sb-ext:gc))
+
+(terpri)
+
+(defparameter *aaa* nil)
+(loop for i below 100 do
+      (princ "!")
+      (force-output)
+      (sb-thread:make-thread
+       #'(lambda ()
+           (let ((*aaa* (waste)))
+             (waste))))
+      (let ((*aaa* (waste)))
+        (waste))
+      (sb-ext:gc))
+
 (format t "~&gc test done~%")
 
+;; this used to deadlock on session-lock
+(sb-thread:make-thread (lambda () (sb-ext:gc)))
+;; expose thread creation races by exiting quickly
+(sb-thread:make-thread (lambda ()))
+
+(defun exercise-syscall (fn reference-errno)
+  (sb-thread:make-thread
+   (lambda ()
+     (loop do
+          (funcall fn)
+          (let ((errno (sb-unix::get-errno)))
+            (sleep (random 0.1d0))
+            (unless (eql errno reference-errno)
+              (format t "Got errno: ~A (~A) instead of ~A~%"
+                      errno
+                      (sb-unix::strerror)
+                      reference-errno)
+              (force-output)
+              (sb-ext:quit :unix-status 1)))))))
+
+;; (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
+                     (open "no-such-file"
+                           :if-does-not-exist nil)
+                     (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))
+                           open-errno)
+         (sb-thread:make-thread (lambda () (loop (sb-ext:gc) (sleep 1)))))))
+  (sleep 10)
+  (princ "terminating threads")
+  (dolist (thread threads)
+    (sb-thread:terminate-thread thread)))
+
+(format t "~&errno test done~%")
+
+(loop repeat 100 do
+      (let ((thread (sb-thread:make-thread (lambda () (sleep 0.1)))))
+        (sb-thread:interrupt-thread
+         thread
+         (lambda ()
+           (assert (find-restart 'sb-thread:terminate-thread))))))
+
+(sb-ext:gc :full t)
+
+(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
+        (make-thread (lambda ()
+                       (sleep 2)
+                       (interrupt-thread main-thread #'break)
+                       (sleep 2)
+                       (interrupt-thread main-thread #'continue))
+                     :name "interruptor")))
+  (with-session-lock (*session*)
+    (sleep 3))
+  (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*
@@ -185,8 +668,211 @@
 |     (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)))))
+
+(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)))
 
-(sb-ext:quit :unix-status 104)
+(format t "hash-cache tests done~%")