Merge branch 'cas-symbol' into 'develop'

Minor improvements to atomic operations

Closes #460

See merge request embeddable-common-lisp/ecl!165

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

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.

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)))