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

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index 60973e0..dd2544c 100644
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -14,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))))
 
@@ -50,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))
@@ -84,12 +101,13 @@
  #-sunos "cc" #+sunos "gcc"
  (or #+(or linux freebsd sunos) '(#+x86-64 "-fPIC"
                                   "-shared" "-o" "threads-foreign.so" "threads-foreign.c")
-     #+darwin '("-dynamiclib" "-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
@@ -419,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
@@ -428,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))
@@ -451,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
@@ -458,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)))
@@ -638,16 +680,15 @@
   (let* ((ok t)
          (threads (loop for i from 0 to 10
                         collect (sb-thread:make-thread
-                                 (let ((i i))
-                                   (lambda ()
-                                     (dotimes (j 100)
-                                       (write-char #\-)
-                                       (finish-output)
-                                       (let ((n (infodb-test)))
-                                         (unless (zerop n)
-                                           (setf ok nil)
-                                           (format t "N != 0 (~A)~%" n)
-                                           (quit))))))))))
+                                 (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)))