From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Thu, 6 Sep 2007 11:49:15 +0000 (+0000)
Subject: 1.0.9.38: fix COMPARE-AND-SWAP
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=828bcd9589641a560e01c2f2bc9134a0aaacd552;p=sbcl.git

1.0.9.38: fix COMPARE-AND-SWAP

* :COMPARE-AND-SWAP-VOPS, not :COMPARE-AND-SWAP-VOP in *FEATURES*.

* Threaded cas tests. (threads.impure.lisp currently broken for
  unrelated reasons since .30 or so.)
---

diff --git a/NEWS b/NEWS
index d8e0a31..875c36c 100644
--- a/NEWS
+++ b/NEWS
@@ -16,6 +16,9 @@ changes in sbcl-1.0.10 relative to sbcl-1.0.9:
   * enhancement: DEFINE-MODIFY-MACRO lambda-list information is
     now more readable in environments like Slime which display it.
     (thanks to Tobias C. Rittweiler)
+  * bug fix: SB-EXT:COMPARE-AND-SWAP was non-atomic unless the compiler
+    was able to infer the correct argument type for the object on which
+    the CAS operation was being performed.
 
 changes in sbcl-1.0.9 relative to sbcl-1.0.8:
   * minor incompatible change: SB-SYS:OUTPUT-RAW-BYTES is deprecated.
diff --git a/make-config.sh b/make-config.sh
index 6727c84..a27deeb 100644
--- a/make-config.sh
+++ b/make-config.sh
@@ -282,7 +282,7 @@ cd $original_dir
 # similar with :STACK-GROWS-FOOWARD, too. -- WHN 2002-03-03
 if [ "$sbcl_arch" = "x86" ]; then
     printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack' >> $ltf
-    printf ' :compare-and-swap-vop :unwind-to-frame-and-call-vop' >> $ltf
+    printf ' :compare-and-swap-vops :unwind-to-frame-and-call-vop' >> $ltf
     printf ' :stack-allocatable-closures :alien-callbacks' >> $ltf
     if [ "$sbcl_os" = "linux" ] || [ "$sbcl_os" = "freebsd" ] || [ "$sbcl_os" = "netbsd" ] || [ "$sbcl_os" = "sunos" ] || [ "$sbcl_os" = "darwin" ] || [ "$sbcl_os" = "win32" ]; then
         printf ' :linkage-table' >> $ltf
@@ -294,7 +294,7 @@ if [ "$sbcl_arch" = "x86" ]; then
     fi
 elif [ "$sbcl_arch" = "x86-64" ]; then
     printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack :linkage-table' >> $ltf
-    printf ' :compare-and-swap-vop :unwind-to-frame-and-call-vop' >> $ltf
+    printf ' :compare-and-swap-vops :unwind-to-frame-and-call-vop' >> $ltf
     printf ' :stack-allocatable-closures :alien-callbacks' >> $ltf
 elif [ "$sbcl_arch" = "mips" ]; then
     printf ' :linkage-table' >> $ltf
diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index dd2544c..cbf5ce6 100644
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -13,6 +13,57 @@
 
 (in-package "SB-THREAD") ; this is white-box testing, really
 
+;;; 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~%")
+
 (use-package :test-util)
 (use-package "ASSERTOID")
 
diff --git a/version.lisp-expr b/version.lisp-expr
index f707ae1..efffb87 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.9.37"
+"1.0.9.38"