(in-package "SB!IMPL") ;;;; COMPARE-AND-SWAP ;;;; ;;;; SB-EXT:COMPARE-AND-SWAP is the public API for now. ;;;; ;;;; Internally our interface has CAS, GET-CAS-EXPANSION, DEFINE-CAS-EXPANDER, ;;;; DEFCAS, and #'(CAS ...) functions -- making things mostly isomorphic with ;;;; SETF. (defglobal **cas-expanders** (make-hash-table :test #'eq #-sb-xc-host #-sb-xc-host :synchronized t)) (define-function-name-syntax cas (list) (destructuring-bind (cas symbol) list (aver (eq 'cas cas)) (values t symbol))) ;;; This is what it all comes down to. (def!macro cas (place old new &environment env) "Synonym for COMPARE-AND-SWAP. Additionally DEFUN, DEFGENERIC, DEFMETHOD, FLET, and LABELS can be also used to define CAS-functions analogously to SETF-functions: (defvar *foo* nil) (defun (cas foo) (old new) (cas (symbol-value '*foo*) old new)) First argument of a CAS function is the expected old value, and the second argument of is the new value. Note that the system provides no automatic atomicity for CAS functions, nor can it verify that they are atomic: it is up to the implementor of a CAS function to ensure its atomicity. EXPERIMENTAL: Interface subject to change." (multiple-value-bind (temps place-args old-temp new-temp cas-form) (get-cas-expansion place env) `(let* (,@(mapcar #'list temps place-args) (,old-temp ,old) (,new-temp ,new)) ,cas-form))) (defun get-cas-expansion (place &optional environment) #!+sb-doc "Analogous to GET-SETF-EXPANSION. Returns the following six values: * list of temporary variables * list of value-forms whose results those variable must be bound * temporary variable for the old value of PLACE * temporary variable for the new value of PLACE * form using the aforementioned temporaries which performs the compare-and-swap operation on PLACE * form using the aforementioned temporaries with which to perform a volatile read of PLACE Example: (get-cas-expansion '(car x)) ; => (#:CONS871), (X), #:OLD872, #:NEW873, ; (SB-KERNEL:%COMPARE-AND-SWAP-CAR #:CONS871 #:OLD872 :NEW873). ; (CAR #:CONS871) (defmacro my-atomic-incf (place &optional (delta 1) &environment env) (multiple-value-bind (vars vals old new cas-form read-form) (get-cas-expansion place env) (let ((delta-value (gensym \"DELTA\"))) `(let* (,@(mapcar 'list vars vals) (,old ,read-form) (,delta-value ,delta) (,new (+ ,old ,delta-value))) (loop until (eq ,old (setf ,old ,cas-form)) do (setf ,new (+ ,old ,delta-value))) ,new)))) EXPERIMENTAL: Interface subject to change." (let ((expanded (sb!xc:macroexpand place environment))) (flet ((invalid-place () (error "Invalid place to CAS: ~S -> ~S" place expanded))) (unless (consp expanded) ;; FIXME: Allow (CAS *FOO* ), maybe? (invalid-place)) (let ((name (car expanded))) (unless (symbolp name) (invalid-place)) (let ((info (gethash name **cas-expanders**))) (cond ;; CAS expander. (info (funcall info expanded environment)) ;; Structure accessor ((setf info (info :function :structure-accessor name)) (expand-structure-slot-cas info name expanded)) ;; CAS function (t (with-unique-names (old new) (let ((vars nil) (vals nil) (args nil)) (dolist (x (reverse (cdr expanded))) (cond ((constantp x environment) (push x args)) (t (let ((tmp (gensymify x))) (push tmp args) (push tmp vars) (push x vals))))) (values vars vals old new `(funcall #'(cas ,name) ,old ,new ,@args) `(,name ,@args))))))))))) (defun expand-structure-slot-cas (dd name place) (let* ((structure (dd-name dd)) (slotd (find name (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)) (destructuring-bind (op arg) place (aver (eq op name)) (with-unique-names (instance old new) (values (list instance) (list arg) old new `(truly-the (values ,type &optional) (%compare-and-swap-instance-ref (the ,structure ,instance) ,index (the ,type ,old) (the ,type ,new))) `(,op ,instance)))))) (def!macro define-cas-expander (accessor lambda-list &body body) "Analogous to DEFINE-SETF-EXPANDER. Defines a CAS-expansion for ACCESSOR. BODY must return six values as specified in GET-CAS-EXPANSION. Note that the system provides no automatic atomicity for CAS expansion, nor can it verify that they are atomic: it is up to the implementor of a CAS expansion to ensure its atomicity. EXPERIMENTAL: Interface subject to change." (with-unique-names (whole environment) (multiple-value-bind (body decls doc) (parse-defmacro lambda-list whole body accessor 'define-cas-expander :environment environment :wrap-block nil) `(eval-when (:compile-toplevel :load-toplevel :execute) (setf (gethash ',accessor **cas-expanders**) (lambda (,whole ,environment) ,@(when doc (list doc)) ,@decls ,body)))))) (def!macro defcas (&whole form accessor lambda-list function &optional docstring) "Analogous to short-form DEFSETF. Defines FUNCTION as responsible for compare-and-swap on places accessed using ACCESSOR. LAMBDA-LIST must correspond to the lambda-list of the accessor. Note that the system provides no automatic atomicity for CAS expansions resulting from DEFCAS, nor can it verify that they are atomic: it is up to the user of DEFCAS to ensure that the function specified is atomic. EXPERIMENTAL: Interface subject to change." (multiple-value-bind (reqs opts restp rest keyp keys allowp auxp) (parse-lambda-list lambda-list) (declare (ignore keys)) (when (or keyp allowp auxp) (error "&KEY, &AUX, and &ALLOW-OTHER-KEYS not allowed in DEFCAS ~ lambda-list.~% ~S" form)) `(define-cas-expander ,accessor ,lambda-list ,@(when docstring (list docstring)) (let ((temps (mapcar #'gensymify ',(append reqs opts (when restp (list (gensymify rest)))))) (args (list ,@(append reqs opts (when restp (list rest))))) (old (gensym "OLD")) (new (gensym "NEW"))) (values temps args old new `(,',function ,@temps ,old ,new) `(,',accessor ,@temps)))))) (def!macro compare-and-swap (place old new) #!+sb-doc "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 CAS-able place. Built-in CAS-able places are accessor forms whose CAR is one of the following: CAR, CDR, FIRST, REST, SVREF, SYMBOL-PLIST, SYMBOL-VALUE, SVREF, SLOT-VALUE SB-MOP:STANDARD-INSTANCE-ACCESS, SB-MOP:FUNCALLABLE-STANDARD-INSTANCE-ACCESS, 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. In case of SLOT-VALUE, if the slot is unbound, SLOT-UNBOUND is called unless OLD is EQ to SB-PCL:+SLOT-UNBOUND+ in which case SB-PCL:+SLOT-UNBOUND+ is returned and NEW is assigned to the slot. Additionally, the results are unspecified if there is an applicable method on either SB-MOP:SLOT-VALUE-USING-CLASS, (SETF SB-MOP:SLOT-VALUE-USING-CLASS), or SB-MOP:SLOT-BOUNDP-USING-CLASS. Additionally, the PLACE can be a anything for which a CAS-expansion has been specified using DEFCAS, DEFINE-CAS-EXPANDER, or for which a CAS-function has been defined. (See SB-EXT:CAS for more information.) " `(cas ,place ,old ,new)) ;;; Out-of-line definitions for various primitive cas functions. (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 (progn #!+sb-thread ,(error "No COMPARE-AND-SWAP-VOPS on a threaded build?") #!-sb-thread (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))