cas: add remcas operation for an expansion removal

It is a (fmakunbound (setf foo)) counterpart.

src/c/symbols_list.h

@@ -1637,6 +1637,7 @@ cl_symbols[] = {
 {MP_ "ATOMIC-INCF-INSTANCE", MP_ORDINARY, IF_MP(mp_atomic_incf_instance), 3, OBJNULL},
 {MP_ "DEFINE-CAS-EXPANDER", MP_CONSTANT, NULL, -1, OBJNULL},
 {MP_ "DEFCAS", MP_CONSTANT, NULL, -1, OBJNULL},
+{MP_ "REMCAS", MP_CONSTANT, NULL, -1, OBJNULL},
 {MP_ "GET-CAS-EXPANSION", MP_CONSTANT, NULL, -1, OBJNULL},
 {MP_ "COMPARE-AND-SWAP", MP_CONSTANT, NULL, -1, OBJNULL},
 {MP_ "ATOMIC-UPDATE", MP_CONSTANT, NULL, -1, OBJNULL},

src/c/symbols_list2.h

@@ -1637,6 +1637,7 @@ cl_symbols[] = {
 {MP_ "ATOMIC-INCF-INSTANCE",IF_MP("mp_atomic_incf_instance")},
 {MP_ "DEFINE-CAS-EXPANDER",NULL},
 {MP_ "DEFCAS",NULL},
+{MP_ "REMCAS",NULL},
 {MP_ "GET-CAS-EXPANSION",NULL},
 {MP_ "COMPARE-AND-SWAP",NULL},
 {MP_ "ATOMIC-UPDATE",NULL},

src/cmp/proclamations.lsp

@@ -778,6 +778,7 @@
 #+threads (proclamation mp:atomic-incf-car (cons fixnum) fixnum)
 #+threads (proclamation mp:compare-and-swap-cdr (cons t t) t)
 #+threads (proclamation mp:atomic-incf-cdr (cons fixnum) fixnum)
+#+threads (proclamation mp:remcas (symbol) boolean)
 
 ;;;
 ;;; 15. ARRAYS

src/doc/manual/extensions/mp_ref_atomic.txi

@@ -227,6 +227,13 @@ Note that it is up to the user of this macro to ensure atomicity for
 the resulting compare-and-swap expansions.
 @end defmac
 
+@lspindex mp:remcas
+@defun mp:remcas symbol
+
+Remove a compare-and-swap expansion. It is an equivalent of
+@code{fmakeunbound (setf symbol)} for cas expansions.
+@end defun
+
 @lspindex mp:get-cas-expansion
 @defun mp:get-cas-expansion place &optional environment
 

src/lsp/mp.lsp

@@ -223,6 +223,12 @@ the resulting COMPARE-AND-SWAP expansions."
                `(,',cas-fun ,@args ,old ,new)
                `(,',accessor ,@args)))))
 
+#+threads
+(defun remcas (symbol)
+  "Remove a COMPARE-AND-SWAP expansion. It is a CAS operation equivalent of
+    (FMAKUNBOUND (SETF SYMBOL))"
+  (si:rem-sysprop symbol 'cas-expander))
+
 #+threads
 (defun get-cas-expansion (place &optional environment &aux f)
   "Returns the COMPARE-AND-SWAP expansion forms and variables as defined

src/tests/normal-tests/multiprocessing.lsp

@@ -704,3 +704,22 @@ creating stray processes."
            (is (svref vector 1) 0)
            (is *x* 0)
            (is (slot-value object 'slot1) 0)))))
+
+;;; Date: 2019-02-05
+;;; From: Daniel Kochmański
+;;; Description:
+;;;
+;;;     Verifies that CAS expansion may be removed.
+;;;
+(ext:with-clean-symbols (*obj* foo)
+  (test defcas/remcas
+        (mp:defcas foo (lambda (object old new)
+                         (assert (consp object))
+                         (setf (car object) old
+                               (cdr object) new)))
+        (defparameter *obj* (cons nil nil))
+        (eval `(mp:compare-and-swap (foo *obj*) :car :cdr))
+        (is (eql (car *obj*) :car))
+        (is (eql (cdr *obj*) :cdr))
+        (mp:remcas 'foo)
+        (signals error (eval `(mp:compare-and-swap (foo *obj*) :car :cdr)))))