5 ;;;; SB-EXT:COMPARE-AND-SWAP is the public API for now.
7 ;;;; Internally our interface has CAS, GET-CAS-EXPANSION, DEFINE-CAS-EXPANDER,
8 ;;;; DEFCAS, and #'(CAS ...) functions -- making things mostly isomorphic with
11 (defglobal **cas-expanders** (make-hash-table :test #'eq :synchronized t))
13 (define-function-name-syntax cas (list)
14 (destructuring-bind (cas symbol) list
18 ;;; This is what it all comes down to.
19 (def!macro cas (place old new &environment env)
20 "Synonym for COMPARE-AND-SWAP.
22 Addtionally DEFUN, DEFGENERIC, DEFMETHOD, FLET, and LABELS can be also used to
23 define CAS-functions analogously to SETF-functions:
27 (defun (cas foo) (old new)
28 (cas (symbol-value '*foo*) old new))
30 First argument of a CAS function is the expected old value, and the second
31 argument of is the new value. Note that the system provides no automatic
32 atomicity for CAS functions, nor can it verify that they are atomic: it is up
33 to the implementor of a CAS function to ensure its atomicity.
35 EXPERIMENTAL: Interface subject to change."
36 (multiple-value-bind (temps place-args old-temp new-temp cas-form)
37 (get-cas-expansion place env)
38 `(let* (,@(mapcar #'list temps place-args)
43 (defun get-cas-expansion (place &optional environment)
45 "Analogous to GET-SETF-EXPANSION. Return six values needed by the CAS
46 machinary: a list of temporary variables, a list of values to which they must
47 be bound, a temporary variable for the old value of PLACE, a temporary value
48 for the new value of PLACE, a form using the aforementioned temporaries
49 which performs the compare-and-swap operation, and a form using the aforementioned
50 temporaries with which to perform a volatile read of the place.
54 (get-cas-expansion '(car x))
55 ; => (#:CONS871), (X), #:OLD872, #:NEW873,
56 ; (SB-KERNEL:%COMPARE-AND-SWAP-CAR #:CONS871 #:OLD872 :NEW873).
59 (defmacro my-atomic-incf (place &optional (delta 1) &environment env)
60 (multiple-value-bind (vars vals old new cas-form read-form)
61 (get-cas-expansion place env)
62 (let ((delta-value (gensym \"DELTA\")))
63 `(let* (,@(mapcar 'list vars vals)
66 (,new (+ ,old ,delta-value)))
67 (loop until (eq ,old (setf ,old ,cas-form))
68 do (setf ,new (+ ,old ,delta-value)))
71 EXPERIMENTAL: Interface subject to change."
72 (flet ((invalid-place ()
73 (error "Invalid place to CAS: ~S" place)))
74 (let ((expanded (sb!xc:macroexpand place environment)))
75 (unless (consp expanded)
76 ;; FIXME: Allow (CAS *FOO* <OLD> <NEW>), maybe?
78 (let ((name (car expanded)))
79 (unless (symbolp name)
81 (let ((info (gethash name **cas-expanders**)))
85 (funcall info place environment))
88 ((setf info (info :function :structure-accessor name))
89 (expand-structure-slot-cas info name expanded))
93 (with-unique-names (old new)
97 (dolist (x (reverse (cdr expanded)))
98 (cond ((constantp x environment)
101 (let ((tmp (gensymify x)))
105 (values vars vals old new
106 `(funcall #'(cas ,name) ,old ,new ,@args)
107 `(,name ,@args)))))))))))
109 (defun expand-structure-slot-cas (dd name place)
110 (let* ((structure (dd-name dd))
111 (slotd (find name (dd-slots dd) :key #'dsd-accessor-name))
112 (index (dsd-index slotd))
113 (type (dsd-type slotd)))
114 (unless (eq t (dsd-raw-type slotd))
115 (error "Cannot use COMPARE-AND-SWAP with structure accessor ~
116 for a typed slot: ~S"
118 (when (dsd-read-only slotd)
119 (error "Cannot use COMPARE-AND-SWAP with structure accessor ~
120 for a read-only slot: ~S"
122 (destructuring-bind (op arg) place
124 (with-unique-names (instance old new)
125 (values (list instance)
129 `(truly-the (values ,type &optional)
130 (%compare-and-swap-instance-ref
131 (the ,structure ,instance)
135 `(,op ,instance))))))
137 (def!macro define-cas-expander (accessor lambda-list &body body)
138 "Analogous to DEFINE-SETF-EXPANDER. Defines a CAS-expansion for ACCESSOR.
139 BODY must return six values as specified in GET-CAS-EXPANSION.
141 Note that the system provides no automatic atomicity for CAS expansion, nor
142 can it verify that they are atomic: it is up to the implementor of a CAS
143 expansion to ensure its atomicity.
145 EXPERIMENTAL: Interface subject to change."
146 (with-unique-names (whole environment)
147 (multiple-value-bind (body decls doc)
148 (parse-defmacro lambda-list whole body accessor
150 :environment environment
152 `(eval-when (:compile-toplevel :load-toplevel :execute)
153 (setf (gethash ',accessor **cas-expanders**)
154 (lambda (,whole ,environment)
155 ,@(when doc (list doc))
159 (def!macro defcas (&whole form accessor lambda-list function
161 "Analogous to short-form DEFSETF. Defines FUNCTION as responsible
162 for compare-and-swap on places accessed using ACCESSOR. LAMBDA-LIST
163 must correspond to the lambda-list of the accessor.
165 Note that the system provides no automatic atomicity for CAS expansions
166 resulting from DEFCAS, nor can it verify that they are atomic: it is up to the
167 user of DEFCAS to ensure that the function specified is atomic.
169 EXPERIMENTAL: Interface subject to change."
170 (multiple-value-bind (reqs opts restp rest keyp keys allowp auxp)
171 (parse-lambda-list lambda-list)
172 (declare (ignore keys))
173 (when (or keyp allowp auxp)
174 (error "&KEY, &AUX, and &ALLOW-OTHER-KEYS not allowed in DEFCAS ~
175 lambda-list.~% ~S" form))
176 `(define-cas-expander ,accessor ,lambda-list
177 ,@(when docstring (list docstring))
178 (let ((temps (mapcar #'gensymify
180 (when restp (list (gensymify rest))))))
181 (args (list ,@(append reqs
183 (when restp (list rest)))))
185 (new (gensym "NEW")))
190 `(,',function ,@temps ,old ,new)
191 `(,',accessor ,@temps))))))
193 (def!macro compare-and-swap (place old new)
195 "Atomically stores NEW in PLACE if OLD matches the current value of PLACE.
196 Two values are considered to match if they are EQ. Returns the previous value
197 of PLACE: if the returned value is EQ to OLD, the swap was carried out.
199 PLACE must be an accessor form whose CAR is one of the following:
201 CAR, CDR, FIRST, REST, SVREF, SYMBOL-PLIST, SYMBOL-VALUE, SVREF, SLOT-VALUE
202 SB-MOP:STANDARD-INSTANCE-ACCESS, SB-MOP:FUNCALLABLE-STANDARD-INSTANCE-ACCESS,
204 or the name of a DEFSTRUCT created accessor for a slot whose declared type is
205 either FIXNUM or T. Results are unspecified if the slot has a declared type
206 other then FIXNUM or T.
208 In case of SLOT-VALUE, if the slot is unbound, SLOT-UNBOUND is called unless
209 OLD is EQ to SB-PCL:+SLOT-UNBOUND+ in which case SB-PCL:+SLOT-UNBOUND+ is
210 returned and NEW is assigned to the slot.
212 Additionally, the results are unspecified if there is an applicable method on
213 either SB-MOP:SLOT-VALUE-USING-CLASS, (SETF SB-MOP:SLOT-VALUE-USING-CLASS), or
214 SB-MOP:SLOT-BOUNDP-USING-CLASS.
216 EXPERIMENTAL: Interface subject to change."
217 `(cas ,place ,old ,new))
219 ;;; Out-of-line definitions for various primitive cas functions.
220 (macrolet ((def (name lambda-list ref &optional set)
221 #!+compare-and-swap-vops
222 (declare (ignore ref set))
223 `(defun ,name (,@lambda-list old new)
224 #!+compare-and-swap-vops
225 (,name ,@lambda-list old new)
226 #!-compare-and-swap-vops
229 ,(error "No COMPARE-AND-SWAP-VOPS on a threaded build?")
231 (let ((current (,ref ,@lambda-list)))
232 (when (eq current old)
234 `(,set ,@lambda-list new)
235 `(setf (,ref ,@lambda-list) new)))
237 (def %compare-and-swap-car (cons) car)
238 (def %compare-and-swap-cdr (cons) cdr)
239 (def %compare-and-swap-instance-ref (instance index) %instance-ref %instance-set)
240 (def %compare-and-swap-symbol-plist (symbol) symbol-plist)
241 (def %compare-and-swap-symbol-value (symbol) symbol-value)
242 (def %compare-and-swap-svref (vector index) svref))