Remove define-cas-expander as a public thing

It still exists, but only because DEFCAS used define-cas-expander.
I plan to remove DEFCAS next; it's every bit as bad.

doc/manual/threading.texinfo

@@ -126,7 +126,6 @@ using @code{get-cas-expansion}. See @code{atomic-update},
 this.
 
 @include macro-sb-ext-cas.texinfo
-@include macro-sb-ext-define-cas-expander.texinfo
 @include macro-sb-ext-defcas.texinfo
 @include fun-sb-ext-get-cas-expansion.texinfo
 

src/code/cas.lisp

@@ -6,36 +6,6 @@
 (defcas rest (cons) %compare-and-swap-cdr)
 (defcas symbol-plist (symbol) %compare-and-swap-symbol-plist)
 
-(define-cas-expander symbol-value (name &environment env)
-  (multiple-value-bind (tmp val cname)
-      (if (constantp name env)
-          (values nil nil (constant-form-value name env))
-          (values (gensymify name) name nil))
-    (let ((symbol (or tmp `',cname)))
-      (with-unique-names (old new)
-        (values (when tmp (list tmp))
-                (when val (list val))
-                old
-                new
-                (if (and cname (member (info :variable :kind cname) '(:special :global)))
-                          ;; We can generate the type-check reasonably.
-                    `(%compare-and-swap-symbol-value
-                      ',cname ,old (the ,(info :variable :type cname) ,new))
-                    `(progn
-                       (about-to-modify-symbol-value ,symbol 'compare-and-swap ,new)
-                       (%compare-and-swap-symbol-value ,symbol ,old ,new)))
-                `(symbol-value ,symbol))))))
-
-(define-cas-expander svref (vector index)
-  (with-unique-names (v i old new)
-    (values (list v i)
-            (list vector index)
-            old
-            new
-            `(locally (declare (simple-vector ,v))
-               (%compare-and-swap-svref ,v (check-bound ,v (length ,v) ,i) ,old ,new))
-            `(svref ,v ,i))))
-
 ;;; Out-of-line definitions for various primitive cas functions.
 (macrolet ((def (name lambda-list ref &optional set)
              #+compare-and-swap-vops

src/code/macros.lisp

@@ -1864,9 +1864,8 @@ symbol-case giving up: case=((V U) (F))
 ;;;;
 ;;;; SB-EXT:COMPARE-AND-SWAP is the public API for now.
 ;;;;
-;;;; Internally our interface has CAS, GET-CAS-EXPANSION, DEFINE-CAS-EXPANDER,
-;;;; DEFCAS, and #'(CAS ...) functions -- making things mostly isomorphic with
-;;;; SETF.
+;;;; Internally our interface has CAS, GET-CAS-EXPANSION,
+;;;; DEFCAS, and #'(CAS ...) functions.
 
 (defun expand-structure-slot-cas (info name place)
   (let* ((dd (car info))
@@ -2010,15 +2009,8 @@ EXPERIMENTAL: Interface subject to change."
             (,new-temp ,new))
        ,cas-form)))
 
-(sb-xc:defmacro define-cas-expander (accessor lambda-list &body body)
-  "Analogous to DEFINE-SETF-EXPANDER. Defines a CAS-expansion for ACCESSOR.
-BODY must return six values as specified in GET-CAS-EXPANSION.
-
-Note that the system provides no automatic atomicity for CAS expansion, nor
-can it verify that they are atomic: it is up to the implementor of a CAS
-expansion to ensure its atomicity.
-
-EXPERIMENTAL: Interface subject to change."
+;; don't use. pending complete removal
+(sb-xc:defmacro %def-cas-expander (accessor lambda-list &body body)
   `(eval-when (:compile-toplevel :load-toplevel :execute)
      (setf (info :cas :expander ',accessor)
            ,(make-macro-lambda `(cas-expand ,accessor) lambda-list body
@@ -2046,7 +2038,7 @@ EXPERIMENTAL: Interface subject to change."
                          :accept (lambda-list-keyword-mask '(&optional &rest))
                          :context "a DEFCAS lambda-list")
     (declare (ignore llks))
-    `(define-cas-expander ,accessor ,lambda-list
+    `(%def-cas-expander ,accessor ,lambda-list
        ,@(when docstring (list docstring))
        ;; FIXME: if a &REST arg is present, this is really weird.
        (let ((temps (mapcar #'gensymify ',(append reqs opts rest)))
@@ -2083,8 +2075,7 @@ unspecified if there is an applicable method on either
 SB-MOP:SLOT-VALUE-USING-CLASS, (SETF SB-MOP:SLOT-VALUE-USING-CLASS), or
 SB-MOP:SLOT-BOUNDP-USING-CLASS.
 
-Additionally, the PLACE can be a anything for which a CAS-expansion has been
-specified using DEFCAS, DEFINE-CAS-EXPANDER, or for which a CAS-function has
+Additionally, the PLACE can be a anything for which a CAS-function has
 been defined. (See SB-EXT:CAS for more information.)
 "
   `(cas ,place ,old ,new))

src/code/stubs.lisp

@@ -13,6 +13,11 @@
 
 (in-package "SB-IMPL")
 
+(defun (cas symbol-value) (old new symbol)
+  (cas (symbol-value symbol) old new))
+(defun (cas svref) (old new vector index)
+  (cas (svref vector index) old new))
+
 (macrolet ((def (name &rest args)
              `(defun ,name ,args
                 (,name ,@args))))

src/cold/package-data-list.lisp-expr

@@ -681,7 +681,6 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
                "CAS"
                "COMPARE-AND-SWAP"
                "DEFCAS"
-               "DEFINE-CAS-EXPANDER"
                "GET-CAS-EXPANSION"
 
                ;; Other atomic operations and types related to them

src/compiler/fndb.lisp

@@ -2077,6 +2077,10 @@
 (defknown sb-kernel::gc-safepoint () (values) ())
 
 ;;;; atomic ops
+;;; the CAS functions are transformed to something else rather than "translated".
+;;; either way, they should not be called.
+(defknown (cas svref) (t t simple-vector index) t (always-translatable))
+(defknown (cas symbol-value) (t t symbol) t (always-translatable))
 (defknown %compare-and-swap-svref (simple-vector index t t) t
     ())
 (defknown (%compare-and-swap-symbol-value

src/compiler/generic/vm-tran.lisp

@@ -768,3 +768,19 @@
 ;; because %PRIMITIVE is not generally fopcompilable.
 (sb-c:define-source-transform make-unbound-marker ()
   `(sb-sys:%primitive make-unbound-marker))
+
+(deftransform (cas symbol-value) ((old new symbol))
+  (let ((cname (and (constant-lvar-p symbol) (lvar-value symbol))))
+    (case (and cname (info :variable :kind cname))
+      ((:special :global)
+       (let ((type (info :variable :type cname)))
+         `(truly-the ,type
+                     (%compare-and-swap-symbol-value ',cname old (the ,type new)))))
+      (t
+       `(progn
+          (about-to-modify-symbol-value symbol 'compare-and-swap new)
+          (%compare-and-swap-symbol-value symbol old new))))))
+
+(deftransform (cas svref) ((old new vector index))
+  '(let ((v (the simple-vector vector)))
+    (%compare-and-swap-svref v (check-bound v (length v) index) old new)))