X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=105df1a2a54cf8390446f3300bd0b30b4cc52e38;hb=1dc3a468ba32755c51747d6e85ed32d989f2dd49;hp=8eb97aed030c1d43853d2691dc13a0338dbfad4c;hpb=bfb7c2d573bacfd9c5f3f243b7c1589f81f11406;p=sbcl.git

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index 8eb97ae..105df1a 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
@@ -420,7 +419,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
@@ -429,6 +430,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))
@@ -709,3 +711,79 @@
            (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~%")