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 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
12 (defun expand-structure-slot-cas (info name place
)
13 (let* ((dd (car info
))
14 (structure (dd-name dd
))
16 (index (dsd-index slotd
))
17 (type (dsd-type slotd
))
19 (case (dsd-raw-type slotd
)
22 ((word) '%raw-instance-cas
/word
))))
24 (error "Cannot use COMPARE-AND-SWAP with structure accessor ~
27 (when (dsd-read-only slotd
)
28 (error "Cannot use COMPARE-AND-SWAP with structure accessor ~
29 for a read-only slot: ~S"
31 (destructuring-bind (op arg
) place
33 (with-unique-names (instance old new
)
34 (values (list instance
)
35 (list `(the ,structure
,arg
))
38 `(truly-the (values ,type
&optional
)
39 (,casser
,instance
,index
44 (defun get-cas-expansion (place &optional environment
)
46 "Analogous to GET-SETF-EXPANSION. Returns the following six values:
48 * list of temporary variables
50 * list of value-forms whose results those variable must be bound
52 * temporary variable for the old value of PLACE
54 * temporary variable for the new value of PLACE
56 * form using the aforementioned temporaries which performs the
57 compare-and-swap operation on PLACE
59 * form using the aforementioned temporaries with which to perform a volatile
64 (get-cas-expansion '(car x))
65 ; => (#:CONS871), (X), #:OLD872, #:NEW873,
66 ; (SB-KERNEL:%COMPARE-AND-SWAP-CAR #:CONS871 #:OLD872 :NEW873).
69 (defmacro my-atomic-incf (place &optional (delta 1) &environment env)
70 (multiple-value-bind (vars vals old new cas-form read-form)
71 (get-cas-expansion place env)
72 (let ((delta-value (gensym \"DELTA\")))
73 `(let* (,@(mapcar 'list vars vals)
76 (,new (+ ,old ,delta-value)))
77 (loop until (eq ,old (setf ,old ,cas-form))
78 do (setf ,new (+ ,old ,delta-value)))
81 EXPERIMENTAL: Interface subject to change."
82 ;; FIXME: this seems wrong on two points:
83 ;; 1. if TRULY-THE had a CAS expander (which it doesn't) we'd want
84 ;; to use %MACROEXPAND[-1] so as not to lose the "truly-the"-ness
85 ;; 2. if both a CAS expander and a macro exist, the CAS expander
86 ;; should be preferred before macroexpanding (just like SETF does)
87 (let ((expanded (sb!xc
:macroexpand place environment
)))
88 (flet ((invalid-place ()
89 (error "Invalid place to CAS: ~S -> ~S" place expanded
)))
90 (unless (consp expanded
)
91 ;; FIXME: Allow (CAS *FOO* <OLD> <NEW>), maybe?
93 (let ((name (car expanded
)))
94 (unless (symbolp name
)
97 ((info :cas
:expander name
)
99 (funcall it expanded environment
))
101 ;; Structure accessor
102 ((structure-instance-accessor-p name
)
103 (expand-structure-slot-cas it name expanded
))
107 (with-unique-names (old new
)
111 (dolist (x (reverse (cdr expanded
)))
112 (cond ((sb!xc
:constantp x environment
)
115 (let ((tmp (gensymify x
)))
119 (values vars vals old new
120 `(funcall #'(cas ,name
) ,old
,new
,@args
)
121 `(,name
,@args
))))))))))
124 ;;; This is what it all comes down to.
125 (defmacro cas
(place old new
&environment env
)
127 "Synonym for COMPARE-AND-SWAP.
129 Additionally DEFUN, DEFGENERIC, DEFMETHOD, FLET, and LABELS can be also used to
130 define CAS-functions analogously to SETF-functions:
134 (defun (cas foo) (old new)
135 (cas (symbol-value '*foo*) old new))
137 First argument of a CAS function is the expected old value, and the second
138 argument of is the new value. Note that the system provides no automatic
139 atomicity for CAS functions, nor can it verify that they are atomic: it is up
140 to the implementor of a CAS function to ensure its atomicity.
142 EXPERIMENTAL: Interface subject to change."
143 (multiple-value-bind (temps place-args old-temp new-temp cas-form
)
144 (get-cas-expansion place env
)
145 `(let* (,@(mapcar #'list temps place-args
)
150 (defmacro define-cas-expander
(accessor lambda-list
&body body
)
152 "Analogous to DEFINE-SETF-EXPANDER. Defines a CAS-expansion for ACCESSOR.
153 BODY must return six values as specified in GET-CAS-EXPANSION.
155 Note that the system provides no automatic atomicity for CAS expansion, nor
156 can it verify that they are atomic: it is up to the implementor of a CAS
157 expansion to ensure its atomicity.
159 EXPERIMENTAL: Interface subject to change."
160 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
161 (setf (info :cas
:expander
',accessor
)
162 ,(make-macro-lambda `(cas-expand ,accessor
) lambda-list body
163 'define-cas-expander accessor
))))
165 ;; FIXME: this interface is bogus - short-form DEFSETF/CAS does not
166 ;; want a lambda-list. You just blindly substitute
167 ;; (CAS (PLACE arg1 ... argN) old new) -> (F arg1 ... argN old new).
168 ;; What role can this lambda-list have when there is no user-provided
169 ;; code to read the variables?
170 ;; And as mentioned no sbcl-devel, &REST is beyond bogus, it's broken.
172 (defmacro defcas
(accessor lambda-list function
&optional docstring
)
174 "Analogous to short-form DEFSETF. Defines FUNCTION as responsible
175 for compare-and-swap on places accessed using ACCESSOR. LAMBDA-LIST
176 must correspond to the lambda-list of the accessor.
178 Note that the system provides no automatic atomicity for CAS expansions
179 resulting from DEFCAS, nor can it verify that they are atomic: it is up to the
180 user of DEFCAS to ensure that the function specified is atomic.
182 EXPERIMENTAL: Interface subject to change."
183 (multiple-value-bind (llks reqs opts rest
)
184 (parse-lambda-list lambda-list
185 :accept
(lambda-list-keyword-mask '(&optional
&rest
))
186 :context
"a DEFCAS lambda-list")
187 (declare (ignore llks
))
188 `(define-cas-expander ,accessor
,lambda-list
189 ,@(when docstring
(list docstring
))
190 ;; FIXME: if a &REST arg is present, this is really weird.
191 (let ((temps (mapcar #'gensymify
',(append reqs opts rest
)))
192 (args (list ,@(append reqs opts rest
)))
194 (new (gensym "NEW")))
199 `(,',function
,@temps
,old
,new
)
200 `(,',accessor
,@temps
))))))
202 (defmacro compare-and-swap
(place old new
)
204 "Atomically stores NEW in PLACE if OLD matches the current value of PLACE.
205 Two values are considered to match if they are EQ. Returns the previous value
206 of PLACE: if the returned value is EQ to OLD, the swap was carried out.
208 PLACE must be an CAS-able place. Built-in CAS-able places are accessor forms
209 whose CAR is one of the following:
211 CAR, CDR, FIRST, REST, SVREF, SYMBOL-PLIST, SYMBOL-VALUE, SVREF, SLOT-VALUE
212 SB-MOP:STANDARD-INSTANCE-ACCESS, SB-MOP:FUNCALLABLE-STANDARD-INSTANCE-ACCESS,
214 or the name of a DEFSTRUCT created accessor for a slot whose declared type is
215 either FIXNUM or T. Results are unspecified if the slot has a declared type
216 other than FIXNUM or T.
218 In case of SLOT-VALUE, if the slot is unbound, SLOT-UNBOUND is called unless
219 OLD is EQ to SB-PCL:+SLOT-UNBOUND+ in which case SB-PCL:+SLOT-UNBOUND+ is
220 returned and NEW is assigned to the slot. Additionally, the results are
221 unspecified if there is an applicable method on either
222 SB-MOP:SLOT-VALUE-USING-CLASS, (SETF SB-MOP:SLOT-VALUE-USING-CLASS), or
223 SB-MOP:SLOT-BOUNDP-USING-CLASS.
225 Additionally, the PLACE can be a anything for which a CAS-expansion has been
226 specified using DEFCAS, DEFINE-CAS-EXPANDER, or for which a CAS-function has
227 been defined. (See SB-EXT:CAS for more information.)
229 `(cas ,place
,old
,new
))
231 (define-cas-expander symbol-value
(name &environment env
)
232 (multiple-value-bind (tmp val cname
)
233 (if (sb!xc
:constantp name env
)
234 (values nil nil
(constant-form-value name env
))
235 (values (gensymify name
) name nil
))
236 (let ((symbol (or tmp
`',cname
)))
237 (with-unique-names (old new
)
238 (values (when tmp
(list tmp
))
239 (when val
(list val
))
244 (about-to-modify-symbol-value ,symbol
'compare-and-swap
,new
)
245 (%compare-and-swap-symbol-value
,symbol
,old
,new
))))
247 (if (member (info :variable
:kind cname
) '(:special
:global
))
248 ;; We can generate the type-check reasonably.
249 `(%compare-and-swap-symbol-value
250 ',cname
,old
(the ,(info :variable
:type cname
) ,new
))
253 `(symbol-value ,symbol
))))))
255 (define-cas-expander svref
(vector index
)
256 (with-unique-names (v i old new
)
261 `(locally (declare (simple-vector ,v
))
262 (%compare-and-swap-svref
,v
(check-bound ,v
(length ,v
) ,i
) ,old
,new
))
265 ;;;; ATOMIC-INCF and ATOMIC-DECF
267 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
268 (defun expand-atomic-frob
269 (name specified-place diff env
270 &aux
(place (sb!xc
:macroexpand specified-place env
)))
271 (declare (type (member atomic-incf atomic-decf
) name
))
272 (flet ((invalid-place ()
273 (error "Invalid first argument to ~S: ~S" name specified-place
))
274 (compute-newval (old) ; used only if no atomic inc vop
275 `(logand (,(case name
(atomic-incf '+) (atomic-decf '-
)) ,old
276 (the sb
!vm
:signed-word
,diff
)) sb
!ext
:most-positive-word
))
277 (compute-delta () ; used only with atomic inc vop
279 (atomic-incf `(the sb
!vm
:signed-word
,diff
))
280 (atomic-decf `(- (the sb
!vm
:signed-word
,diff
))))
281 sb
!ext
:most-positive-word
)))
282 (declare (ignorable #'compute-newval
#'compute-delta
))
283 (when (and (symbolp place
)
284 (eq (info :variable
:kind place
) :global
)
285 (type= (info :variable
:type place
) (specifier-type 'fixnum
)))
286 ;; Global can't be lexically rebound.
287 (return-from expand-atomic-frob
288 `(truly-the fixnum
(,(case name
289 (atomic-incf '%atomic-inc-symbol-global-value
)
290 (atomic-decf '%atomic-dec-symbol-global-value
))
291 ',place
(the fixnum
,diff
)))))
292 (unless (consp place
) (invalid-place))
293 (destructuring-bind (op . args
) place
294 ;; FIXME: The lexical environment should not be disregarded.
295 ;; CL builtins can't be lexically rebound, but structure accessors can.
298 (unless (singleton-p (cdr args
))
300 (with-unique-names (array)
301 `(let ((,array
(the (simple-array word
(*)) ,(car args
))))
302 #!+compare-and-swap-vops
303 (%array-atomic-incf
/word
305 (check-bound ,array
(array-dimension ,array
0) ,(cadr args
))
307 #!-compare-and-swap-vops
308 ,(with-unique-names (index old-value
)
310 (let* ((,index
,(cadr args
))
311 (,old-value
(aref ,array
,index
)))
312 (setf (aref ,array
,index
) ,(compute-newval old-value
))
314 ((car cdr first rest
)
320 ((first car
) (case name
321 (atomic-incf '%atomic-inc-car
)
322 (atomic-decf '%atomic-dec-car
)))
323 ((rest cdr
) (case name
324 (atomic-incf '%atomic-inc-cdr
)
325 (atomic-decf '%atomic-dec-cdr
))))
326 ,(car args
) (the fixnum
,diff
))))
329 ;; Because accessor info is identical for the writer and reader
330 ;; functions, without a SYMBOLP check this would erroneously allow
331 ;; (ATOMIC-INCF ((SETF STRUCT-SLOT) x))
333 (not (structure-instance-accessor-p op
)))
335 (let* ((accessor-info (structure-instance-accessor-p op
))
336 (slotd (cdr accessor-info
))
337 (type (dsd-type slotd
)))
338 (unless (and (eq 'sb
!vm
:word
(dsd-raw-type slotd
))
339 (type= (specifier-type type
) (specifier-type 'sb
!vm
:word
)))
340 (error "~S requires a slot of type (UNSIGNED-BYTE ~S), not ~S: ~S"
341 name sb
!vm
:n-word-bits type place
))
342 (when (dsd-read-only slotd
)
343 (error "Cannot use ~S with structure accessor for a read-only slot: ~S"
345 #!+compare-and-swap-vops
346 `(truly-the sb
!vm
:word
347 (%raw-instance-atomic-incf
/word
348 (the ,(dd-name (car accessor-info
)) ,@args
)
351 #!-compare-and-swap-vops
352 (with-unique-names (structure old-value
)
354 (let* ((,structure
,@args
)
355 (,old-value
(,op
,structure
)))
356 (setf (,op
,structure
) ,(compute-newval old-value
))
359 (defmacro atomic-incf
(&environment env place
&optional
(diff 1))
362 "Atomically increments PLACE by DIFF, and returns the value of PLACE before
365 PLACE must access one of the following:
366 - a DEFSTRUCT slot with declared type (UNSIGNED-BYTE ~D~:*)
367 or AREF of a (SIMPLE-ARRAY (UNSIGNED-BYTE ~D~:*) (*))
368 The type SB-EXT:WORD can be used for these purposes.
369 - CAR or CDR (respectively FIRST or REST) of a CONS.
370 - a variable defined using DEFGLOBAL with a proclaimed type of FIXNUM.
371 Macroexpansion is performed on PLACE before expanding ATOMIC-INCF.
373 Incrementing is done using modular arithmetic,
374 which is well-defined over two different domains:
375 - For structures and arrays, the operation accepts and produces
376 an (UNSIGNED-BYTE ~D~:*), and DIFF must be of type (SIGNED-BYTE ~D).
377 ATOMIC-INCF of #x~x by one results in #x0 being stored in PLACE.
378 - For other places, the domain is FIXNUM, and DIFF must be a FIXNUM.
379 ATOMIC-INCF of #x~x by one results in #x~x
380 being stored in PLACE.
384 EXPERIMENTAL: Interface subject to change."
385 sb
!vm
:n-word-bits most-positive-word
386 sb
!xc
:most-positive-fixnum sb
!xc
:most-negative-fixnum
)
387 (expand-atomic-frob 'atomic-incf place diff env
))
389 (defmacro atomic-decf
(&environment env place
&optional
(diff 1))
392 "Atomically decrements PLACE by DIFF, and returns the value of PLACE before
395 PLACE must access one of the following:
396 - a DEFSTRUCT slot with declared type (UNSIGNED-BYTE ~D~:*)
397 or AREF of a (SIMPLE-ARRAY (UNSIGNED-BYTE ~D~:*) (*))
398 The type SB-EXT:WORD can be used for these purposes.
399 - CAR or CDR (respectively FIRST or REST) of a CONS.
400 - a variable defined using DEFGLOBAL with a proclaimed type of FIXNUM.
401 Macroexpansion is performed on PLACE before expanding ATOMIC-DECF.
403 Decrementing is done using modular arithmetic,
404 which is well-defined over two different domains:
405 - For structures and arrays, the operation accepts and produces
406 an (UNSIGNED-BYTE ~D~:*), and DIFF must be of type (SIGNED-BYTE ~D).
407 ATOMIC-DECF of #x0 by one results in #x~x being stored in PLACE.
408 - For other places, the domain is FIXNUM, and DIFF must be a FIXNUM.
409 ATOMIC-DECF of #x~x by one results in #x~x
410 being stored in PLACE.
414 EXPERIMENTAL: Interface subject to change."
415 sb
!vm
:n-word-bits most-positive-word
416 sb
!xc
:most-negative-fixnum sb
!xc
:most-positive-fixnum
)
417 (expand-atomic-frob 'atomic-decf place diff env
))
419 ;; Interpreter stubs for ATOMIC-INCF.
420 #!+(and compare-and-swap-vops
(host-feature sb-xc
))
422 ;; argument types are declared in vm-fndb
423 (defun %array-atomic-incf
/word
(array index diff
)
424 (%array-atomic-incf
/word array index diff
))
425 (defun %raw-instance-atomic-incf
/word
(instance index diff
)
426 (%raw-instance-atomic-incf
/word instance index diff
)))