From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Sun, 15 Jul 2007 22:28:12 +0000 (+0000)
Subject: 1.0.7.19: SB-EXT:COMPARE-AND-SWAP
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=bfb19d306581ac86feb4371846c4b9953d692dd8;p=sbcl.git

1.0.7.19: SB-EXT:COMPARE-AND-SWAP

 * New macro SB-EXT:COMPARE-AND-SWAP provides a supported interface to
   compare-and-swap functionality.

 * New info-type :FUNCTION :STRUCTURE-ACCESSOR allows us to map from
   defstruct slot-accessor names to defstruct descriptions.

 * Add :CAS-TRANS slot keyword to DEFINE-PRIMITIVE object, and the
   compiler machinery needed to support compare and swap on primitive
   object slots.

 * New VOPs COMPARE-AND-SWAP-SLOT and %COMPARE-AND-SWAP-SYMBOL-VALUE.

 * Delete now unnecessary DEFINE-STRUCTURE-SLOT-COMPARE-AND-SWAP.

 * Use a consistent %COMPARE-AND-SWAP-FOO naming scheme for CAS
   functions.

 * Tests.

 Tested on x86/Linux & x86/Darwin, x86-64/Darwi, and PPC/Darwin.
---

diff --git a/NEWS b/NEWS
index f6c1203..47475d0 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,7 @@
 ;;;; -*- coding: utf-8; -*-
 changes in sbcl-1.0.8 relative to sbcl-1.0.7:
+  * enhancement: experimental macro SB-EXT:COMPARE-AND-SWAP provides
+    atomic compare-and-swap operations on threaded platforms.
   * enhancement: experimental function SB-EXT:RESTRICT-COMPILER-POLICY
     allows assining a global minimum value to optimization qualities
     (overriding proclamations and declarations).
diff --git a/base-target-features.lisp-expr b/base-target-features.lisp-expr
index 93066ab..d614afa 100644
--- a/base-target-features.lisp-expr
+++ b/base-target-features.lisp-expr
@@ -323,6 +323,9 @@
  ;;   :alien-callbacks
  ;;     Alien callbacks have been implemented for this platform.
  ;;
+ ;;   :compare-and-swap-vops
+ ;;     The backend implements compare-and-swap VOPs.
+ ;;
  ;; operating system features:
  ;;   :linux   = We're intended to run under some version of Linux.
  ;;   :bsd     = We're intended to run under some version of BSD Unix. (This
diff --git a/make-config.sh b/make-config.sh
index fa2da8a..ce0c8f2 100644
--- a/make-config.sh
+++ b/make-config.sh
@@ -274,7 +274,8 @@ cd $original_dir
 # if we're building for x86. -- CSR, 2002-02-21 Then we do something
 # 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  :unwind-to-frame-and-call-vop' >> $ltf
+    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 ' :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
@@ -285,7 +286,8 @@ if [ "$sbcl_arch" = "x86" ]; then
         printf ' :os-provides-dlopen' >> $ltf
     fi
 elif [ "$sbcl_arch" = "x86-64" ]; then
-    printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack :linkage-table :unwind-to-frame-and-call-vop' >> $ltf
+    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 ' :stack-allocatable-closures :alien-callbacks' >> $ltf
 elif [ "$sbcl_arch" = "mips" ]; then
     printf ' :linkage-table' >> $ltf
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 5040759..3db36ee 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -240,6 +240,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)"
                "CLOSURE-INIT" "CLOSURE-REF"
                "CODE-CONSTANT-REF" "CODE-CONSTANT-SET"
                "*CODE-COVERAGE-INFO*"
+               "COMPARE-AND-SWAP-SLOT"
                "COMPILE-IN-LEXENV"
                "COMPILE-LAMBDA-FOR-DEFUN"
                "%COMPILER-DEFUN" "COMPILER-ERROR" "FATAL-COMPILER-ERROR"
@@ -338,6 +339,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)"
                "VAR-ALLOC"
                "SAFE-FDEFN-FUN"
                "NOTE-FIXUP"
+               "DEF-CASSER"
                "DEF-REFFER"
                "EMIT-NOP"
                "DEF-SETTER"
@@ -578,6 +580,8 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
                "*POSIX-ARGV*" "*CORE-PATHNAME*"
                "POSIX-GETENV" "POSIX-ENVIRON"
 
+               "COMPARE-AND-SWAP"
+
                ;; People have various good reasons to mess with the GC.
                "*AFTER-GC-HOOKS*"
                "BYTES-CONSED-BETWEEN-GCS"
@@ -1137,7 +1141,14 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "%ARRAY-FILL-POINTER-P" "%ARRAY-RANK" "%ASIN" "%ASINH"
                "%ATAN" "%ATAN2" "%ATANH" "%CALLER-FRAME-AND-PC"
                "%CHECK-BOUND" "%CHECK-VECTOR-SEQUENCE-BOUNDS"
-               "%CLOSURE-FUN" "%CLOSURE-INDEX-REF" "%COS" "%COS-QUICK"
+               "%CLOSURE-FUN" "%CLOSURE-INDEX-REF"
+               "%COMPARE-AND-SWAP-CAR"
+               "%COMPARE-AND-SWAP-CDR"
+               "%COMPARE-AND-SWAP-INSTANCE-REF"
+               "%COMPARE-AND-SWAP-SVREF"
+               "%COMPARE-AND-SWAP-SYMBOL-PLIST"
+               "%COMPARE-AND-SWAP-SYMBOL-VALUE"
+               "%COS" "%COS-QUICK"
                "%COSH" "%DATA-VECTOR-AND-INDEX" "%DEPOSIT-FIELD"
                "%DOUBLE-FLOAT" "%DPB" "%EQL" "%EXP" "%EXPM1" "%FIND-POSITION"
                "%FIND-POSITION-VECTOR-MACRO" "%FIND-POSITION-IF"
@@ -1180,7 +1191,6 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "%SET-SIGNED-SAP-REF-WORD"
                "%SET-SIGNED-SAP-REF-8" "%SET-STACK-REF"
                "%SET-SYMBOL-HASH"
-               "%SIMPLE-VECTOR-COMPARE-AND-SWAP"
                "%SIN" "%SIN-QUICK" "%SINGLE-FLOAT"
                "%SINH" "%SQRT" "%SXHASH-SIMPLE-STRING"
                "%SXHASH-SIMPLE-SUBSTRING" "%TAN" "%TAN-QUICK" "%TANH"
@@ -1246,7 +1256,6 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                #!+long-float "DECODE-LONG-FLOAT"
                "DECODE-SINGLE-FLOAT"
                "DEFINE-STRUCTURE-SLOT-ADDRESSOR"
-               "DEFINE-STRUCTURE-SLOT-COMPARE-AND-SWAP"
                "DEFINED-FTYPE-MATCHES-DECLARED-FTYPE-P"
                "!DEFSTRUCT-WITH-ALTERNATE-METACLASS" "DESCEND-INTO"
                "DISPLACED-TO-ARRAY-TOO-SMALL-ERROR"
@@ -1463,7 +1472,6 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "SIMPLE-ARRAY-SIGNED-BYTE-8-P" "SIMPLE-BASE-STRING-P"
                #!+sb-unicode "SIMPLE-CHARACTER-STRING-P"
                "SIMPLE-PACKAGE-ERROR" "SIMPLE-UNBOXED-ARRAY"
-               "SIMPLE-VECTOR-COMPARE-AND-SWAP"
                "SINGLE-FLOAT-BITS" "SINGLE-FLOAT-EXPONENT"
                "SINGLE-FLOAT-INT-EXPONENT" "SINGLE-FLOAT-SIGNIFICAND"
                "SINGLE-VALUE-TYPE" "SINGLE-VALUE-SPECIFIER-TYPE"
@@ -1471,7 +1479,6 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "STACK-REF" "STREAM-DESIGNATOR" "STRING-DESIGNATOR"
                "STRUCTURE-RAW-SLOT-TYPE-AND-SIZE" "SUB-GC"
                "SYMBOLS-DESIGNATOR"
-               "%INSTANCE-COMPARE-AND-SWAP"
                "%INSTANCE-LENGTH"
                "%INSTANCE-REF"
                "%INSTANCE-SET"
diff --git a/src/code/array.lisp b/src/code/array.lisp
index 286d197..817bdb7 100644
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -56,19 +56,6 @@
         (values vector index))
       (values array index)))
 
-(declaim (inline simple-vector-compare-and-swap))
-(defun simple-vector-compare-and-swap (vector index old new)
-  #!+(or x86 x86-64)
-  (%simple-vector-compare-and-swap vector
-                                   (%check-bound vector (length vector) index)
-                                   old
-                                   new)
-  #!-(or x86 x86-64)
-  (let ((n-old (svref vector index)))
-    (when (eq old n-old)
-      (setf (svref vector index) new))
-    n-old))
-
 ;;; It'd waste space to expand copies of error handling in every
 ;;; inline %WITH-ARRAY-DATA, so we have them call this function
 ;;; instead. This is just a wrapper which is known never to return.
diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 4559697..338c09a 100644
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -1034,6 +1034,7 @@
       (let* ((accessor-name (dsd-accessor-name dsd))
              (dsd-type (dsd-type dsd)))
         (when accessor-name
+          (setf (info :function :structure-accessor accessor-name) dd)
           (let ((inherited (accessor-inherited-data accessor-name dd)))
             (cond
               ((not inherited)
diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp
index 7fed988..f6c5f25 100644
--- a/src/code/late-extensions.lisp
+++ b/src/code/late-extensions.lisp
@@ -48,26 +48,7 @@
 
 ;;; Used internally, but it would be nice to provide something
 ;;; like this for users as well.
-(defmacro define-structure-slot-compare-and-swap
-    (name &key structure slot)
-  (let* ((dd (find-defstruct-description structure t))
-         (slotd (when dd (find slot (dd-slots dd) :key #'dsd-name)))
-         (type (when slotd (dsd-type slotd)))
-         (index (when slotd (dsd-index slotd))))
-    (unless index
-      (error "Slot ~S not found in ~S." slot structure))
-    (unless (eq t (dsd-raw-type slotd))
-      (error "Cannot define compare-and-swap on a raw slot."))
-    (when (dsd-read-only slotd)
-      (error "Cannot define compare-and-swap on a read-only slot."))
-    `(progn
-       (declaim (inline ,name))
-       (defun ,name (instance old new)
-         (declare (type ,structure instance)
-                  (type ,type old new))
-         (%instance-compare-and-swap instance ,index old new)))))
 
-;;; Ditto
 #!+sb-thread
 (defmacro define-structure-slot-addressor (name &key structure slot)
   (let* ((dd (find-defstruct-description structure t))
@@ -85,3 +66,77 @@
              (- (* ,(+ sb!vm:instance-slots-offset index) sb!vm:n-word-bytes)
                 sb!vm:instance-pointer-lowtag)))))))
 
+(defmacro compare-and-swap (place old new)
+  "Atomically stores NEW in PLACE if OLD matches the current value of PLACE.
+Two values are considered to match if they are EQ. Returns the previous value
+of PLACE: if the returned value if EQ to OLD, the swap was carried out.
+
+PLACE must be an accessor form whose CAR is one of the following:
+
+ CAR, CDR, FIRST, REST, SYMBOL-PLIST, SYMBOL-VALUE, SVREF
+
+or the name of a DEFSTRUCT created accessor for a slot whose declared type is
+either FIXNUM or T. Results are unspecified if the slot has a declared type
+other then FIXNUM or T.
+
+EXPERIMENTAL: Interface subject to change."
+  (flet ((invalid-place ()
+           (error "Invalid first argument to COMPARE-AND-SWAP: ~S" place)))
+    (unless (consp place)
+      (invalid-place))
+  ;; FIXME: Not the nicest way to do this...
+  (destructuring-bind (op &rest args) place
+    (case op
+      ((car first)
+       `(%compare-and-swap-car (the cons ,@args) ,old ,new))
+      ((cdr rest)
+       `(%compare-and-swap-cdr (the cons ,@args) ,old ,new))
+      (symbol-plist
+       `(%compare-and-swap-symbol-plist (the symbol ,@args) ,old ,new))
+      (symbol-value
+       `(%compare-and-swap-symbol-value (the symbol ,@args) ,old ,new))
+      (svref
+       (let ((vector (car args))
+             (index (cadr args)))
+         (unless (and vector index (not (cddr args)))
+           (invalid-place))
+         (with-unique-names (v)
+           `(let ((,v ,vector))
+              (declare (simple-vector ,v))
+              (%compare-and-swap-svref ,v (%check-bound ,v (length ,v) ,index) ,old ,new)))))
+      (t
+       (let ((dd (info :function :structure-accessor op)))
+         (if dd
+             (let* ((structure (dd-name dd))
+                    (slotd (find op (dd-slots dd) :key #'dsd-accessor-name))
+                    (index (dsd-index slotd))
+                    (type (dsd-type slotd)))
+               (unless (eq t (dsd-raw-type slotd))
+                 (error "Cannot use COMPARE-AND-SWAP with structure accessor for a typed slot: ~S"
+                        place))
+               (when (dsd-read-only slotd)
+                 (error "Cannot use COMPARE-AND-SWAP with structure accessor for a read-only slot: ~S"
+                        place))
+               `(truly-the (values ,type &optional)
+                           (%compare-and-swap-instance-ref (the ,structure ,@args)
+                                                           ,index
+                                                           (the ,type ,old) (the ,type ,new))))
+             (error "Invalid first argument to COMPARE-AND-SWAP: ~S" place))))))))
+
+(macrolet ((def (name lambda-list ref &optional set)
+             `(defun ,name (,@lambda-list old new)
+                #!+compare-and-swap-vops
+                (,name ,@lambda-list old new)
+                #!-compare-and-swap-vops
+                (let ((current (,ref ,@lambda-list)))
+                  (when (eq current old)
+                    ,(if set
+                         `(,set ,@lambda-list new)
+                         `(setf (,ref ,@lambda-list) new)))
+                  current))))
+  (def %compare-and-swap-car (cons) car)
+  (def %compare-and-swap-cdr (cons) cdr)
+  (def %compare-and-swap-instance-ref (instance index) %instance-ref %instance-set)
+  (def %compare-and-swap-symbol-plist (symbol) symbol-plist)
+  (def %compare-and-swap-symbol-value (symbol) symbol-value)
+  (def %compare-and-swap-svref (vector index) svref))
diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index 2f462ef..176c4f5 100644
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -31,15 +31,6 @@
 (defun %instance-set (instance index new-value)
   (setf (%instance-ref instance index) new-value))
 
-(defun %instance-compare-and-swap (instance index old new)
-  #!+(or x86 x86-64)
-  (%instance-compare-and-swap instance index old new)
-  #!-(or x86 x86-64)
-  (let ((n-old (%instance-ref instance index)))
-    (when (eq old n-old)
-      (%instance-set instance index new))
-    n-old))
-
 #!-hppa
 (progn
   (defun %raw-instance-ref/word (instance index)
diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index c831dc5..19f2747 100644
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -181,25 +181,19 @@ in future versions."
   (declare (type (unsigned-byte 27) n))
   (sb!vm::current-thread-offset-sap n))
 
-;;;; spinlocks
-(define-structure-slot-compare-and-swap
-    compare-and-swap-spinlock-value
-    :structure spinlock
-    :slot value)
-
 (declaim (inline get-spinlock release-spinlock))
 
 ;; Should always be called with interrupts disabled.
 (defun get-spinlock (spinlock)
   (declare (optimize (speed 3) (safety 0)))
   (let* ((new *current-thread*)
-         (old (compare-and-swap-spinlock-value spinlock nil new)))
+         (old (sb!ext:compare-and-swap (spinlock-value spinlock) nil new)))
     (when old
       (when (eq old new)
         (error "Recursive lock attempt on ~S." spinlock))
       #!+sb-thread
       (flet ((cas ()
-               (unless (compare-and-swap-spinlock-value spinlock nil new)
+               (unless (sb!ext:compare-and-swap (spinlock-value spinlock) nil new)
                  (return-from get-spinlock t))))
         (if (and (not *interrupts-enabled*) *allow-with-interrupts*)
             ;; If interrupts are enabled, but we are allowed to enabled them,
@@ -226,14 +220,9 @@ in future versions."
       "The value of the mutex. NIL if the mutex is free. Setfable.")
 
 #!+(and sb-thread (not sb-lutex))
-(progn
-  (define-structure-slot-addressor mutex-value-address
+(define-structure-slot-addressor mutex-value-address
       :structure mutex
       :slot value)
-  (define-structure-slot-compare-and-swap
-      compare-and-swap-mutex-value
-      :structure mutex
-      :slot value))
 
 (defun get-mutex (mutex &optional (new-value *current-thread*) (waitp t))
   #!+sb-doc
@@ -275,7 +264,7 @@ NIL. If WAITP is non-NIL and the mutex is in use, sleep until it is available."
       (setf (mutex-value mutex) new-value))
     #!-sb-lutex
     (let (old)
-      (when (and (setf old (compare-and-swap-mutex-value mutex nil new-value))
+      (when (and (setf old (sb!ext:compare-and-swap (mutex-value mutex) nil new-value))
                  waitp)
         (loop while old
               do (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
@@ -285,7 +274,7 @@ NIL. If WAITP is non-NIL and the mutex is in use, sleep until it is available."
                                             (or to-sec -1)
                                             (or to-usec 0))))
                      (signal-deadline)))
-              (setf old (compare-and-swap-mutex-value mutex nil new-value))))
+              (setf old (sb!ext:compare-and-swap (mutex-value mutex) nil new-value))))
       (not old))))
 
 (defun release-mutex (mutex)
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 7ba684b..46b3aa9 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -1554,9 +1554,9 @@
 (defknown style-warn (string &rest t) null ())
 
 ;;;; atomic ops
-#!+(or x86 x86-64)
-(progn
-  (defknown %simple-vector-compare-and-swap (simple-vector index t t) t
-      (unsafe))
-  (defknown %instance-compare-and-swap (instance index t t) t
-      (unsafe)))
+(defknown %compare-and-swap-svref (simple-vector index t t) t
+    (unsafe))
+(defknown %compare-and-swap-instance-ref (instance index t t) t
+    (unsafe))
+(defknown %compare-and-swap-symbol-value (symbol t t) t
+    (unsafe unwind))
diff --git a/src/compiler/fun-info-funs.lisp b/src/compiler/fun-info-funs.lisp
index a5b6290..600e735 100644
--- a/src/compiler/fun-info-funs.lisp
+++ b/src/compiler/fun-info-funs.lisp
@@ -34,3 +34,9 @@
                 (ir2-convert-fixed-allocation node block name words header
                                               lowtag inits)))))
   name)
+
+(defun %def-casser (name offset lowtag)
+  (let ((fun-info (fun-info-or-lose name)))
+    (setf (fun-info-ir2-convert fun-info)
+          (lambda (node block)
+            (ir2-convert-casser node block name offset lowtag)))))
diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp
index 15d86cc..f4c515d 100644
--- a/src/compiler/generic/objdef.lisp
+++ b/src/compiler/generic/objdef.lisp
@@ -40,8 +40,10 @@
 
 (define-primitive-object (cons :lowtag list-pointer-lowtag
                                :alloc-trans cons)
-  (car :ref-trans car :set-trans sb!c::%rplaca :init :arg)
-  (cdr :ref-trans cdr :set-trans sb!c::%rplacd :init :arg))
+  (car :ref-trans car :set-trans sb!c::%rplaca :init :arg
+       :cas-trans %compare-and-swap-car)
+  (cdr :ref-trans cdr :set-trans sb!c::%rplacd :init :arg
+       :cas-trans %compare-and-swap-cdr))
 
 (define-primitive-object (instance :lowtag instance-pointer-lowtag
                                    :widetag instance-header-widetag
@@ -321,6 +323,7 @@
 
   (plist :ref-trans symbol-plist
          :set-trans %set-symbol-plist
+         :cas-trans %compare-and-swap-symbol-plist
          :init :null)
   (name :ref-trans symbol-name :init :arg)
   (package :ref-trans symbol-package
diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp
index c9e064a..5f924b5 100644
--- a/src/compiler/generic/vm-ir2tran.lisp
+++ b/src/compiler/generic/vm-ir2tran.lisp
@@ -32,6 +32,20 @@
          name offset lowtag)
     (move-lvar-result node block (list value-tn) (node-lvar node))))
 
+#!+compare-and-swap-vops
+(defoptimizer ir2-convert-casser
+    ((object old new) node block name offset lowtag)
+  (let* ((lvar (node-lvar node))
+         (locs (lvar-result-tns lvar (list *backend-t-primitive-type*)))
+         (res (first locs)))
+    (vop compare-and-swap-slot node block
+         (lvar-tn node block object)
+         (lvar-tn node block old)
+         (lvar-tn node block new)
+         name offset lowtag
+         res)
+    (move-lvar-result node block locs lvar)))
+
 (defun emit-inits (node block name result lowtag inits args)
   (let ((unbound-marker-tn nil)
         (funcallable-instance-tramp-tn nil))
diff --git a/src/compiler/generic/vm-macs.lisp b/src/compiler/generic/vm-macs.lisp
index b6bc5a9..184861f 100644
--- a/src/compiler/generic/vm-macs.lisp
+++ b/src/compiler/generic/vm-macs.lisp
@@ -76,6 +76,7 @@
                        ((:type slot-type) t) init
                        (ref-known nil ref-known-p) ref-trans
                        (set-known nil set-known-p) set-trans
+                       cas-trans
                        &allow-other-keys)
             (if (atom spec) (list spec) spec)
           (slots (make-slot slot-name docs rest-p offset
@@ -99,6 +100,15 @@
                                 ,slot-type
                         ,set-known)))
             (forms `(def-setter ,set-trans ,offset ,lowtag)))
+          (when cas-trans
+            (when rest-p
+              (error ":REST-P and :CAS-TRANS incompatible."))
+            (forms
+             `(progn
+                (defknown ,cas-trans (,type ,slot-type ,slot-type)
+                    ,slot-type (unsafe))
+                #!+compare-and-swap-vops
+                (def-casser ,cas-trans ,offset ,lowtag))))
           (when init
             (inits (cons init offset)))
           (when rest-p
@@ -133,6 +143,9 @@
   `(%def-setter ',name ,offset ,lowtag))
 (defmacro def-alloc (name words variable-length-p header lowtag inits)
   `(%def-alloc ',name ,words ,variable-length-p ,header ,lowtag ,inits))
+#!+compare-and-swap-vops
+(defmacro def-casser (name offset lowtag)
+  `(%def-casser ',name ,offset ,lowtag))
 ;;; KLUDGE: The %DEF-FOO functions used to implement the macros here
 ;;; are defined later in another file, since they use structure slot
 ;;; setters defined later, and we can't have physical forward
diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp
index c5e1a7a..bc68512 100644
--- a/src/compiler/globaldb.lisp
+++ b/src/compiler/globaldb.lisp
@@ -1050,6 +1050,12 @@
   :type :definition
   :type-spec (or fdefn null)
   :default nil)
+
+(define-info-type
+  :class :function
+  :type :structure-accessor
+  :type-spec (or defstruct-description null)
+  :default nil)
 
 ;;;; definitions for other miscellaneous information
 
diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp
index ebbfcac..685d3b7 100644
--- a/src/compiler/info-functions.lisp
+++ b/src/compiler/info-functions.lisp
@@ -97,6 +97,7 @@
       (frob :kind)
       (frob :inline-expansion-designator)
       (frob :source-transform)
+      (frob :structure-accessor)
       (frob :assumed-type)))
   (values))
 
diff --git a/src/compiler/x86-64/array.lisp b/src/compiler/x86-64/array.lisp
index 006d9dd..c73b4eb 100644
--- a/src/compiler/x86-64/array.lisp
+++ b/src/compiler/x86-64/array.lisp
@@ -157,10 +157,10 @@
   (def-full-data-vector-frobs simple-array-unsigned-byte-63 unsigned-num
     unsigned-reg))
 
-(define-full-compare-and-swap simple-vector-compare-and-swap
-    simple-vector vector-data-offset other-pointer-lowtag
-    (descriptor-reg any-reg) *
-    %simple-vector-compare-and-swap)
+(define-full-compare-and-swap %compare-and-swap-svref simple-vector
+  vector-data-offset other-pointer-lowtag
+  (descriptor-reg any-reg) *
+  %compare-and-swap-svref)
 
 ;;;; integer vectors whose elements are smaller than a byte, i.e.,
 ;;;; bit, 2-bit, and 4-bit vectors
diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp
index 8c2dd11..3a4d571 100644
--- a/src/compiler/x86-64/cell.lisp
+++ b/src/compiler/x86-64/cell.lisp
@@ -46,11 +46,67 @@
                           temp))
         ;; Else, value not immediate.
         (storew value object offset lowtag))))
-
-
 
+(define-vop (compare-and-swap-slot)
+  (:args (object :scs (descriptor-reg) :to :eval)
+         (old :scs (descriptor-reg any-reg) :target rax)
+         (new :scs (descriptor-reg any-reg)))
+  (:temporary (:sc descriptor-reg :offset rax-offset
+                   :from (:argument 1) :to :result :target result)
+              rax)
+  (:info name offset lowtag)
+  (:ignore name)
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:generator 5
+     (move rax old)
+     #!+sb-thread
+     (inst lock)
+     (inst cmpxchg (make-ea :qword :base object
+                            :disp (- (* offset n-word-bytes) lowtag))
+           new)
+     (move result rax)))
+
 ;;;; symbol hacking VOPs
 
+(define-vop (%compare-and-swap-symbol-value)
+  (:translate %compare-and-swap-symbol-value)
+  (:args (symbol :scs (descriptor-reg) :to (:result 1))
+         (old :scs (descriptor-reg any-reg) :target rax)
+         (new :scs (descriptor-reg any-reg)))
+  (:temporary (:sc descriptor-reg :offset rax-offset) rax)
+  #!+sb-thread
+  (:temporary (:sc descriptor-reg) tls)
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 15
+    ;; This code has to pathological cases: NO-TLS-VALUE-MARKER
+    ;; or UNBOUND-MARKER as NEW: in either case we would end up
+    ;; doing possible damage with CMPXCHG -- so don't do that!
+    (let ((unbound (generate-error-code vop unbound-symbol-error symbol))
+          (check (gen-label)))
+      (move rax old)
+      #!+sb-thread
+      (progn
+        (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
+        ;; Thread-local area, not LOCK needed.
+        (inst cmpxchg (make-ea :qword :base thread-base-tn
+                               :index tls :scale 1)
+              new)
+        (inst cmp rax no-tls-value-marker-widetag)
+        (inst jmp :ne check)
+        (move rax old)
+        (inst lock))
+      (inst cmpxchg (make-ea :qword :base symbol
+                             :disp (- (* symbol-value-slot n-word-bytes)
+                                      other-pointer-lowtag)
+                             :scale 1)
+            new)
+      (emit-label check)
+      (move result rax)
+      (inst cmp result unbound-marker-widetag)
+      (inst jmp :e unbound))))
+
 ;;; these next two cf the sparc version, by jrd.
 ;;; FIXME: Deref this ^ reference.
 
@@ -463,9 +519,10 @@
 (define-full-setter instance-index-set * instance-slots-offset
   instance-pointer-lowtag (any-reg descriptor-reg) * %instance-set)
 
-(define-full-compare-and-swap instance-compare-and-swap instance
-  instance-slots-offset instance-pointer-lowtag (any-reg descriptor-reg)
-  * %instance-compare-and-swap)
+(define-full-compare-and-swap %compare-and-swap-instance-ref instance
+  instance-slots-offset instance-pointer-lowtag
+  (any-reg descriptor-reg) *
+  %compare-and-swap-instance-ref)
 
 ;;;; code object frobbing
 
diff --git a/src/compiler/x86/array.lisp b/src/compiler/x86/array.lisp
index 0b12e75..3d49c01 100644
--- a/src/compiler/x86/array.lisp
+++ b/src/compiler/x86/array.lisp
@@ -150,10 +150,10 @@
   #!+sb-unicode
   (def-full-data-vector-frobs simple-character-string character character-reg))
 
-(define-full-compare-and-swap simple-vector-compare-and-swap
-    simple-vector vector-data-offset other-pointer-lowtag
-    (descriptor-reg any-reg) *
-    %simple-vector-compare-and-swap)
+(define-full-compare-and-swap %compare-and-swap-svref simple-vector
+  vector-data-offset other-pointer-lowtag
+  (descriptor-reg any-reg) *
+  %compare-and-swap-svref)
 
 ;;;; integer vectors whose elements are smaller than a byte, i.e.,
 ;;;; bit, 2-bit, and 4-bit vectors
diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp
index 83277ce..d8e5a34 100644
--- a/src/compiler/x86/cell.lisp
+++ b/src/compiler/x86/cell.lisp
@@ -29,11 +29,65 @@
   (:results)
   (:generator 1
      (storew (encode-value-if-immediate value) object offset lowtag)))
-
-
 
+(define-vop (compare-and-swap-slot)
+  (:args (object :scs (descriptor-reg) :to :eval)
+         (old :scs (descriptor-reg any-reg) :target eax)
+         (new :scs (descriptor-reg any-reg)))
+  (:temporary (:sc descriptor-reg :offset eax-offset
+                   :from (:argument 1) :to :result :target result)
+              eax)
+  (:info name offset lowtag)
+  (:ignore name)
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:generator 5
+     (move eax old)
+     #!+sb-thread
+     (inst lock)
+     (inst cmpxchg (make-ea :dword :base object
+                            :disp (- (* offset n-word-bytes) lowtag))
+           new)
+     (move result eax)))
+
 ;;;; symbol hacking VOPs
 
+(define-vop (%compare-and-swap-symbol-value)
+  (:translate %compare-and-swap-symbol-value)
+  (:args (symbol :scs (descriptor-reg) :to (:result 1))
+         (old :scs (descriptor-reg any-reg) :target eax)
+         (new :scs (descriptor-reg any-reg)))
+  (:temporary (:sc descriptor-reg :offset eax-offset) eax)
+  #!+sb-thread
+  (:temporary (:sc descriptor-reg) tls)
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 15
+    ;; This code has to pathological cases: NO-TLS-VALUE-MARKER
+    ;; or UNBOUND-MARKER as NEW: in either case we would end up
+    ;; doing possible damage with CMPXCHG -- so don't do that!
+    (let ((unbound (generate-error-code vop unbound-symbol-error symbol))
+          (check (gen-label)))
+      (move eax old)
+      #!+sb-thread
+      (progn
+        (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
+        ;; Thread-local area, not LOCK needed.
+        (inst fs-segment-prefix)
+        (inst cmpxchg (make-ea :dword :base tls) new)
+        (inst cmp eax no-tls-value-marker-widetag)
+        (inst jmp :ne check)
+        (move eax old)
+        (inst lock))
+      (inst cmpxchg (make-ea :dword :base symbol
+                             :disp (- (* symbol-value-slot n-word-bytes)
+                                      other-pointer-lowtag))
+            new)
+      (emit-label check)
+      (move result eax)
+      (inst cmp result unbound-marker-widetag)
+      (inst jmp :e unbound))))
+
 ;;; these next two cf the sparc version, by jrd.
 ;;; FIXME: Deref this ^ reference.
 
@@ -446,10 +500,10 @@
   (any-reg descriptor-reg) *
   %instance-set)
 
-(define-full-compare-and-swap instance-compare-and-swap instance
+(define-full-compare-and-swap %compare-and-swap-instance-ref instance
   instance-slots-offset instance-pointer-lowtag
   (any-reg descriptor-reg) *
-  %instance-compare-and-swap)
+  %compare-and-swap-instance-ref)
 
 ;;;; code object frobbing
 
diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp
index b4d3e9d..f70a2a8 100644
--- a/src/pcl/cache.lisp
+++ b/src/pcl/cache.lisp
@@ -149,22 +149,6 @@
 (defun cache-key-p (thing)
   (not (symbolp thing)))
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (sb-kernel:define-structure-slot-compare-and-swap compare-and-swap-cache-depth
-      :structure cache
-      :slot depth))
-
-;;; Utility macro for atomic updates without locking... doesn't
-;;; do much right now, and it would be nice to make this more magical.
-(defmacro compare-and-swap (place old new)
-  (unless (consp place)
-    (error "Don't know how to compare and swap ~S." place))
-  (ecase (car place)
-    (svref
-     `(simple-vector-compare-and-swap ,@(cdr place) ,old ,new))
-    (cache-depth
-     `(compare-and-swap-cache-depth ,@(cdr place) ,old ,new))))
-
 ;;; Atomically update the current probe depth of a cache.
 (defun note-cache-depth (cache depth)
   (loop for old = (cache-depth cache)
diff --git a/tests/array.pure.lisp b/tests/array.pure.lisp
index fe9c4f0..d04416d 100644
--- a/tests/array.pure.lisp
+++ b/tests/array.pure.lisp
@@ -221,25 +221,3 @@
               (type-error ()
                 :good))))
 
-;;; SIMPLE-VECTOR-COMPARE-AND-SWAP
-
-(let ((v (vector 1)))
-  ;; basics
-  (assert (eql 1 (sb-kernel:simple-vector-compare-and-swap v 0 1 2)))
-  (assert (eql 2 (sb-kernel:simple-vector-compare-and-swap v 0 1 3)))
-  (assert (eql 2 (svref v 0)))
-  ;; bounds
-  (multiple-value-bind (res err)
-      (ignore-errors (sb-kernel:simple-vector-compare-and-swap v -1 1 2))
-    (assert (not res))
-    (assert (typep err 'type-error)))
-  (multiple-value-bind (res err)
-      (ignore-errors (sb-kernel:simple-vector-compare-and-swap v 1 1 2))
-    (assert (not res))
-    (assert (typep err 'type-error))))
-
-;; type of the first argument
-(multiple-value-bind (res err)
-    (ignore-errors (sb-kernel:simple-vector-compare-and-swap "foo" 1 1 2))
-    (assert (not res))
-    (assert (typep err 'type-error)))
diff --git a/tests/compare-and-swap.impure.lisp b/tests/compare-and-swap.impure.lisp
new file mode 100644
index 0000000..6366043
--- /dev/null
+++ b/tests/compare-and-swap.impure.lisp
@@ -0,0 +1,77 @@
+;;; Basics
+
+(defstruct xxx yyy)
+
+(macrolet ((test (init op)
+             `(let ((x ,init)
+                    (y (list 'foo))
+                    (z (list 'bar)))
+                (assert (eql nil (compare-and-swap (,op x) nil y)))
+                (assert (eql y (compare-and-swap (,op x) nil z)))
+                (assert (eql y (,op x)))
+                (let ((x "foo"))
+                  (multiple-value-bind (res err)
+                     (ignore-errors (compare-and-swap (,op x) nil nil))
+                    (assert (not res))
+                    (assert (typep err 'type-error)))))))
+  (test (cons nil :no) car)
+  (test (cons nil :no) first)
+  (test (cons :no nil) cdr)
+  (test (cons :no nil) rest)
+  (test '.foo. symbol-plist)
+  (test (progn (set '.bar. nil) '.bar.) symbol-value)
+  (test (make-xxx) xxx-yyy))
+
+(defvar *foo*)
+
+;;; thread-local bindings
+
+(let ((*foo* 42))
+  (let ((*foo* nil))
+    (assert (eql nil (compare-and-swap (symbol-value '*foo*) nil t)))
+    (assert (eql t (compare-and-swap (symbol-value '*foo*) nil :foo)))
+    (assert (eql t *foo*)))
+  (assert (eql 42 *foo*)))
+
+;;; unbound symbols + symbol-value
+
+(assert (not (boundp '*foo*)))
+
+(multiple-value-bind (res err)
+    (ignore-errors (compare-and-swap (symbol-value '*foo*) nil t))
+  (assert (not res))
+  (assert (typep err 'unbound-variable)))
+
+(defvar *bar* t)
+
+(let ((*bar* nil))
+   (makunbound '*bar*)
+   (multiple-value-bind (res err)
+       (ignore-errors (compare-and-swap (symbol-value '*bar*) nil t))
+     (assert (not res))
+     (assert (typep err 'unbound-variable))))
+
+;;; SVREF
+
+(defvar *v* (vector 1))
+
+;; basics
+(assert (eql 1 (compare-and-swap (svref *v* 0) 1 2)))
+(assert (eql 2 (compare-and-swap (svref *v* 0) 1 3)))
+(assert (eql 2 (svref *v* 0)))
+
+;; bounds
+(multiple-value-bind (res err)
+    (ignore-errors (compare-and-swap (svref *v* -1) 1 2))
+  (assert (not res))
+  (assert (typep err 'type-error)))
+(multiple-value-bind (res err)
+    (ignore-errors (compare-and-swap (svref *v* 1) 1 2))
+  (assert (not res))
+  (assert (typep err 'type-error)))
+
+;; type of the first argument
+(multiple-value-bind (res err)
+    (ignore-errors (compare-and-swap (svref "foo" 1) 1 2))
+    (assert (not res))
+    (assert (typep err 'type-error)))
diff --git a/version.lisp-expr b/version.lisp-expr
index a7c5e78..1e4713d 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.7.18"
+"1.0.7.19"