sb!vm:n-word-bytes)
sb!vm:instance-pointer-lowtag)))))))
-(defmacro compare-and-swap (place old new &environment env)
- "Atomically stores NEW in PLACE if OLD matches the current value of PLACE.
-Two values are considered to match if they are EQ. Returns the previous value
-of PLACE: if the returned value is EQ to OLD, the swap was carried out.
-
-PLACE must be an accessor form whose CAR is one of the following:
-
- CAR, CDR, FIRST, REST, SYMBOL-PLIST, SYMBOL-VALUE, SVREF
-
-or the name of a DEFSTRUCT created accessor for a slot whose declared type is
-either FIXNUM or T. Results are unspecified if the slot has a declared type
-other then FIXNUM or T.
-
-EXPERIMENTAL: Interface subject to change."
- (flet ((invalid-place ()
- (error "Invalid first argument to COMPARE-AND-SWAP: ~S" place)))
- (unless (consp place)
- (invalid-place))
- ;; FIXME: Not the nicest way to do this...
- (destructuring-bind (op &rest args) place
- (case op
- ((car first)
- `(%compare-and-swap-car (the cons ,@args) ,old ,new))
- ((cdr rest)
- `(%compare-and-swap-cdr (the cons ,@args) ,old ,new))
- (symbol-plist
- `(%compare-and-swap-symbol-plist (the symbol ,@args) ,old (the list ,new)))
- (symbol-value
- (destructuring-bind (name) args
- (flet ((slow (symbol)
- (with-unique-names (n-symbol n-old n-new)
- `(let ((,n-symbol ,symbol)
- (,n-old ,old)
- (,n-new ,new))
- (declare (symbol ,n-symbol))
- (about-to-modify-symbol-value ,n-symbol 'compare-and-swap ,n-new)
- (%compare-and-swap-symbol-value ,n-symbol ,n-old ,n-new)))))
- (if (sb!xc:constantp name env)
- (let ((cname (constant-form-value name env)))
- (if (eq :special (info :variable :kind cname))
- ;; Since we know the symbol is a special, we can just generate
- ;; the type check.
- `(%compare-and-swap-symbol-value
- ',cname ,old (the ,(info :variable :type cname) ,new))
- (slow (list 'quote cname))))
- (slow name)))))
- (svref
- (let ((vector (car args))
- (index (cadr args)))
- (unless (and vector index (not (cddr args)))
- (invalid-place))
- (with-unique-names (v)
- `(let ((,v ,vector))
- (declare (simple-vector ,v))
- (%compare-and-swap-svref ,v (%check-bound ,v (length ,v) ,index) ,old ,new)))))
- (t
- (let ((dd (info :function :structure-accessor op)))
- (if dd
- (let* ((structure (dd-name dd))
- (slotd (find op (dd-slots dd) :key #'dsd-accessor-name))
- (index (dsd-index slotd))
- (type (dsd-type slotd)))
- (unless (eq t (dsd-raw-type slotd))
- (error "Cannot use COMPARE-AND-SWAP with structure accessor for a typed slot: ~S"
- place))
- (when (dsd-read-only slotd)
- (error "Cannot use COMPARE-AND-SWAP with structure accessor for a read-only slot: ~S"
- place))
- `(truly-the (values ,type &optional)
- (%compare-and-swap-instance-ref (the ,structure ,@args)
- ,index
- (the ,type ,old) (the ,type ,new))))
- (error "Invalid first argument to COMPARE-AND-SWAP: ~S" place))))))))
-
-(macrolet ((def (name lambda-list ref &optional set)
- #!+compare-and-swap-vops
- (declare (ignore ref set))
- `(defun ,name (,@lambda-list old new)
- #!+compare-and-swap-vops
- (,name ,@lambda-list old new)
- #!-compare-and-swap-vops
- (let ((current (,ref ,@lambda-list)))
- (when (eq current old)
- ,(if set
- `(,set ,@lambda-list new)
- `(setf (,ref ,@lambda-list) new)))
- current))))
- (def %compare-and-swap-car (cons) car)
- (def %compare-and-swap-cdr (cons) cdr)
- (def %compare-and-swap-instance-ref (instance index) %instance-ref %instance-set)
- (def %compare-and-swap-symbol-plist (symbol) symbol-plist)
- (def %compare-and-swap-symbol-value (symbol) symbol-value)
- (def %compare-and-swap-svref (vector index) svref))
+;;;; ATOMIC-INCF and ATOMIC-DECF
(defun expand-atomic-frob (name place diff)
(flet ((invalid-place ()
projects / sbcl.git / blobdiff