X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=311e1d5c4656f4df46e8cfbab0ad8be0ac30d504;hb=e8571be6d533b80768bdae4e3e15316e4faa22fa;hp=0e43d628f63caac747c0bffc6828ead0d95d7dd3;hpb=374667fd8a38e79869e63d56bacde7ad98a40852;p=sbcl.git

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index 0e43d62..311e1d5 100644
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -17,7 +17,7 @@
 (use-package :test-util)
 (use-package "ASSERTOID")
 
-(setf sb-unix::*on-dangerous-select* :error)
+(setf sb-unix::*on-dangerous-wait* :error)
 
 (defun wait-for-threads (threads)
   (mapc (lambda (thread) (sb-thread:join-thread thread :default nil)) threads)
@@ -154,16 +154,16 @@
   (sleep 3)
   (assert (not (thread-alive-p thread))))
 
-(with-test (:name '(:join-thread :nlx :default))
+(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))
+(with-test (:name (:join-thread :nlx :error))
   (raises-error? (join-thread (make-thread (lambda () (sb-ext:quit))))
                  join-thread-error))
 
-(with-test (:name '(:join-thread :multiple-values))
+(with-test (:name (:join-thread :multiple-values))
   (assert (equal '(1 2 3)
                  (multiple-value-list
                   (join-thread (make-thread (lambda () (values 1 2 3))))))))
@@ -198,14 +198,10 @@
 
 (with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
   (format o "void loop_forever() { while(1) ; }~%"))
-(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-ext:run-program "/bin/sh"
+                    '("run-compiler.sh" "-sbcl-pic" "-sbcl-shared"
+                      "-o" "threads-foreign.so" "threads-foreign.c")
+                    :environment (test-util::test-env))
 (sb-alien:load-shared-object (truename "threads-foreign.so"))
 (sb-alien:define-alien-routine loop-forever sb-alien:void)
 (delete-file "threads-foreign.c")
@@ -348,11 +344,18 @@
 (with-test (:name (:grab-mutex :timeout :acquisition-fail))
   #+sb-lutex
   (error "Mutex timeout not supported here.")
-  (let ((m (make-mutex)))
+  (let ((m (make-mutex))
+        (w (make-semaphore)))
     (with-mutex (m)
-      (assert (null (join-thread (make-thread
-                                  #'(lambda ()
-                                      (grab-mutex m :timeout 0.1)))))))))
+      (let ((th (make-thread
+                 #'(lambda ()
+                     (prog1
+                         (grab-mutex m :timeout 0.1)
+                       (signal-semaphore w))))))
+        ;; Wait for it to -- otherwise the detect the deadlock chain
+        ;; from JOIN-THREAD.
+        (wait-on-semaphore w)
+        (assert (null (join-thread th)))))))
 
 (with-test (:name (:grab-mutex :timeout :acquisition-success))
   #+sb-lutex
@@ -367,16 +370,18 @@
 (with-test (:name (:grab-mutex :timeout+deadline))
   #+sb-lutex
   (error "Mutex timeout not supported here.")
-  (let ((m (make-mutex)))
+  (let ((m (make-mutex))
+        (w (make-semaphore)))
     (with-mutex (m)
-      (assert (eq (join-thread
-                   (make-thread #'(lambda ()
-                                    (sb-sys:with-deadline (:seconds 0.0)
-                                      (handler-case
-                                          (grab-mutex m :timeout 0.0)
-                                        (sb-sys:deadline-timeout ()
-                                          :deadline))))))
-                  :deadline)))))
+      (let ((th (make-thread #'(lambda ()
+                                 (sb-sys:with-deadline (:seconds 0.0)
+                                   (handler-case
+                                       (grab-mutex m :timeout 0.0)
+                                     (sb-sys:deadline-timeout ()
+                                       (signal-semaphore w)
+                                       :deadline)))))))
+        (wait-on-semaphore w)
+        (assert (eq (join-thread th) :deadline))))))
 
 (with-test (:name (:grab-mutex :waitp+deadline))
   #+sb-lutex
@@ -563,8 +568,6 @@
 (defun alloc-stuff () (copy-list '(1 2 3 4 5)))
 
 (with-test (:name (:interrupt-thread :interrupt-consing-child))
-  #+darwin
-  (error "Hangs on Darwin.")
   (let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff))))))
     (let ((killers
            (loop repeat 4 collect
@@ -582,9 +585,8 @@
 
 (format t "~&multi interrupt test done~%")
 
+#+(or x86 x86-64) ;; x86oid-only, see internal commentary.
 (with-test (:name (:interrupt-thread :interrupt-consing-child :again))
-  #+darwin
-  (error "Hangs on Darwin.")
   (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
@@ -672,8 +674,6 @@
     (assert (sb-thread:join-thread thread))))
 
 (with-test (:name (:two-threads-running-gc))
-  #+darwin
-  (error "Hangs on Darwin.")
   (let (a-done b-done)
     (make-thread (lambda ()
                    (dotimes (i 100)
@@ -995,8 +995,6 @@
 (format t "~&multiple reader hash table test done~%")
 
 (with-test (:name (:hash-table-single-accessor-parallel-gc))
-  #+darwin
-  (error "Prone to hang on Darwin due to interrupt issues.")
   (let ((hash (make-hash-table))
         (*errors* nil))
     (let ((threads (list (sb-thread:make-thread
@@ -1334,7 +1332,7 @@
   (format t "ok~%")
   (force-output))
 
-(with-test (:name '(:hash-cache :subtypep))
+(with-test (:name (:hash-cache :subtypep))
   (dotimes (i 10)
     (sb-thread:make-thread #'subtypep-hash-cache-test)))
 (format t "hash-cache tests done~%")