diff --git a/src/doc/manual/extensions/mp_ref_atomic.txi b/src/doc/manual/extensions/mp_ref_atomic.txi index a9dcb45c8..9cf8fff8b 100644 --- a/src/doc/manual/extensions/mp_ref_atomic.txi +++ b/src/doc/manual/extensions/mp_ref_atomic.txi @@ -98,10 +98,12 @@ Currently, the following places are supported: @code{car}, @code{cdr}, @code{first}, @code{rest}, @code{svref}, @code{symbol-plist}, @code{symbol-value}, @code{slot-value}, @code{clos:standard-instance-access}, -@code{clos:funcallable-standard-instance-access}, a struct accessor -defined by @code{defstruct} with the @code{:atomic-accessors} option -enabled or any other place for which a compare-and-swap expansion was -defined by @code{mp:defcas} or @code{mp:define-cas-expander}. +@code{clos:funcallable-standard-instance-access}, a structure slot +accessor@footnote{The creation of atomic structure slot accessors can be +deactivated by supplying a @code{(:atomic-accessors nil)} option to +@code{defstruct}.} or any other place for which a compare-and-swap +expansion was defined by @code{mp:defcas} or +@code{mp:define-cas-expander}. For @code{slot-value}, @code{slot-unbound} is called if the slot is unbound unless @var{old} is @code{eq} to @code{si:unbound}, in which @@ -129,7 +131,7 @@ Example: Atomic update of a structure slot. If the update would not be atomic, the result would be unpredictable. @lisp -(defstruct (test-struct :atomic-accessors) +(defstruct test-struct (slot1 0)) (let ((struct (make-test-struct))) (mapc #'mp:process-join diff --git a/src/lsp/defstruct.lsp b/src/lsp/defstruct.lsp index db76a1579..3b568b8d0 100644 --- a/src/lsp/defstruct.lsp +++ b/src/lsp/defstruct.lsp @@ -427,7 +427,7 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)." print-function print-object type named initial-offset offset name-offset documentation - atomic-accessors) + (atomic-accessors t)) ;; Parse the defstruct options. (do ((os options (cdr os)) (o) (v)) @@ -461,6 +461,7 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)." `(function ,v)))) (:TYPE (setq type v)) (:INITIAL-OFFSET (setq initial-offset v)) + (:ATOMIC-ACCESSORS (setq atomic-accessors v)) (t (error "~S is an illegal defstruct option." o)))) (t (if (consp (car os)) @@ -472,9 +473,8 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)." (cons default-constructor constructors))) (:CONC-NAME (setq conc-name nil)) - ((:COPIER :PREDICATE :PRINT-FUNCTION :PRINT-OBJECT)) + ((:COPIER :PREDICATE :PRINT-FUNCTION :PRINT-OBJECT :ATOMIC-ACCESSORS)) (:NAMED (setq named t)) - (:ATOMIC-ACCESSORS (setq atomic-accessors t)) (t (error "~S is an illegal defstruct option." o)))))) ;; Skip the documentation string. diff --git a/src/lsp/mp.lsp b/src/lsp/mp.lsp index ee8884573..35d9feb6b 100644 --- a/src/lsp/mp.lsp +++ b/src/lsp/mp.lsp @@ -232,6 +232,17 @@ the resulting COMPARE-AND-SWAP expansions." `(,',cas-fun ,@args ,old ,new) `(,',accessor ,@args))))) +;; XXX - Hacky way to determine at macroexpand time whether place is a +;; special variable (works for both bytecodes and native compiler). To +;; be replaced by a better way once the cltl2 environment access is +;; implemented (see issue #63). -- mg 2019-10-31 +(defun special-variable-p (place) + (declare (si::c-local)) + (and (symbolp place) + (or (and (fboundp 'c::special-variable-p) + (c::special-variable-p place)) + (si:specialp place)))) + #+threads (defun remcas (symbol) "Remove a COMPARE-AND-SWAP expansion. It is a CAS operation equivalent of @@ -251,6 +262,8 @@ the resulting COMPARE-AND-SWAP expansions." (defun get-cas-expansion (place &optional environment &aux f) "Returns the COMPARE-AND-SWAP expansion forms and variables as defined in DEFINE-CAS-EXPANDER for PLACE as six values." + (when (special-variable-p place) + (setf place `(symbol-value ',place))) (cond ((and (listp place) (setq f (si:get-sysprop (first place) 'CAS-EXPANDER))) (apply f environment (rest place))) @@ -270,8 +283,7 @@ Currently, the following places are supported: car, cdr, first, rest, svref, symbol-plist, symbol-value, slot-value, clos:standard-instance-access, clos:funcallable-standard-instance-access, -a struct accessor defined by defstruct with the :atomic-accessors -option enabled or any other place for which a compare-and-swap +a struct accessor or any other place for which a compare-and-swap expansion was defined by defcas or define-cas-expander. For slot-value, slot-unbound is called if the slot is unbound unless @@ -364,16 +376,21 @@ for slot-value-using-class or (setf slot-value-using-class). The consequences are undefined if the value of PLACE is not of type fixnum." #+threads - (let* ((place (macroexpand place)) - (fun (case (first place) - ((car first) 'mp:atomic-incf-car) - ((cdr rest) 'mp:atomic-incf-cdr) - (symbol-value 'mp:atomic-incf-symbol-value) - (svref 'mp:atomic-incf-svref) - (slot-value 'mp::atomic-incf-slot-value) - ((clos:standard-instance-access clos:funcallable-standard-instance-access) 'mp::atomic-incf-standard-instance) - (t (error "No ATOMIC-INCF expansion defined for place ~S." place))))) - `(,fun ,@(rest place) ,increment)) + (progn + (setf place (macroexpand place)) + (when (special-variable-p place) + (setf place `(symbol-value ',place))) + (let ((fun (when (listp place) + (case (first place) + ((car first) 'mp:atomic-incf-car) + ((cdr rest) 'mp:atomic-incf-cdr) + (symbol-value 'mp:atomic-incf-symbol-value) + (svref 'mp:atomic-incf-svref) + (slot-value 'mp::atomic-incf-slot-value) + ((clos:standard-instance-access clos:funcallable-standard-instance-access) 'mp::atomic-incf-standard-instance))))) + (unless fun + (error "No ATOMIC-INCF expansion defined for place ~S." place)) + `(,fun ,@(rest place) ,increment))) #-threads (let ((value (gensym)) (incr (gensym)))