diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 1f8303016..0d0946323 100755 --- a/src/c/symbols_list.h +++ b/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}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index bea81ecc3..d541baeb1 100644 --- a/src/c/symbols_list2.h +++ b/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}, diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index 1cac7ef09..c627df03f 100644 --- a/src/cmp/proclamations.lsp +++ b/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 diff --git a/src/doc/manual/extensions/mp_ref_atomic.txi b/src/doc/manual/extensions/mp_ref_atomic.txi index c99b34011..6b663070d 100644 --- a/src/doc/manual/extensions/mp_ref_atomic.txi +++ b/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 diff --git a/src/lsp/mp.lsp b/src/lsp/mp.lsp index f261a156c..ad220e2b8 100644 --- a/src/lsp/mp.lsp +++ b/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 diff --git a/src/tests/normal-tests/multiprocessing.lsp b/src/tests/normal-tests/multiprocessing.lsp index a165e850a..41b5d15aa 100644 --- a/src/tests/normal-tests/multiprocessing.lsp +++ b/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)))))