1.0.9.41: Fix test on unthreaded config.

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

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index 3800bbc..867f408 100644 (file)
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -16,6 +16,8 @@
 (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))))
@@ -41,6 +43,57 @@
 
 #-sb-thread (sb-ext:quit :unix-status 104)
 
+;;; 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~%")
+
 (let ((old-threads (list-all-threads))
       (thread (make-thread (lambda ()
                              (assert (find *current-thread* *all-threads*))
@@ -99,12 +152,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"))
@@ -126,16 +180,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
@@ -469,6 +542,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
@@ -476,7 +550,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)))