From 12fedc5fe3bb0af61998e89eaeea783ccacb0d25 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Sat, 26 Oct 2019 19:44:59 +0200 Subject: [PATCH 1/2] multiprocessing: create atomic structure slot accessors by default Previously we were only creating atomic accessors when explicitely told so, which is problematic for compatibility reasons, since it requires compatibility libraries to define their own versions of defstruct just for ECL. This change is backwards compatible. --- src/doc/manual/extensions/mp_ref_atomic.txi | 12 +++++++----- src/lsp/defstruct.lsp | 6 +++--- src/lsp/mp.lsp | 3 +-- 3 files changed, 11 insertions(+), 10 deletions(-) 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..50fa148a9 100644 --- a/src/lsp/mp.lsp +++ b/src/lsp/mp.lsp @@ -270,8 +270,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 From 7b388fa00de9341e76477f956542ce33cf9c29b8 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Sun, 9 Dec 2018 13:29:19 +0100 Subject: [PATCH 2/2] threading: make atomics work directly on special variables Allowing e.g. (atomic-incf *foo*) instead of requiring (atomic-incf (symbol-value '*foo*)) makes the interface easier to use and more consistent with sbcl. --- src/lsp/mp.lsp | 38 ++++++++++++++++++++++++++++---------- 1 file changed, 28 insertions(+), 10 deletions(-) diff --git a/src/lsp/mp.lsp b/src/lsp/mp.lsp index 50fa148a9..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))) @@ -363,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)))