X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=c68b61518da484e4fe9ebcd79245da81760d058f;hb=b76dac3d5f89700f3a076403157eae3c52e4c118;hp=eb4fe5a1b71a7c461777acdfdcdbbf05178758a3;hpb=c548f73e8dd676d6ec4576eba6ab661a5061bdfe;p=sbcl.git

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index eb4fe5a..c68b615 100644
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -43,6 +43,58 @@
 
 #-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
+                                   do (sb-thread:thread-yield))
+                                (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*))
@@ -107,7 +159,7 @@
  :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"))