0.9.16.29:

[sbcl.git] / tests / threads.impure.lisp

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index c285c81..43a60f3 100644 (file)
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -83,7 +83,8 @@
   (format o "void loop_forever() { while(1) ; }~%"))
 (sb-ext:run-program
  #-sunos "cc" #+sunos "gcc"
- (or #+(or linux freebsd sunos) '("-shared" "-o" "threads-foreign.so" "threads-foreign.c")
+ (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")
      (error "Missing shared library compilation options for this platform"))
  :search t)
@@ -318,7 +319,8 @@
                       (lambda ()
                         (princ ".") (force-output)
                         (assert (thread-alive-p *current-thread*))
-                        (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
+                        (assert
+                         (not (logbitp 0 SB-KERNEL:*PSEUDO-ATOMIC-BITS*))))))
   (terminate-thread c)
   (wait-for-threads (list c)))
 
@@ -609,11 +611,62 @@
               (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
+                                 (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))))))))))
+    (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~%")