src/code/cas.lisp

   1 (in-package "SB!IMPL")
   2
   3 ;;;; COMPARE-AND-SWAP
   4 ;;;;
   5 ;;;; SB-EXT:COMPARE-AND-SWAP is the public API for now.
   6 ;;;;
   7 ;;;; Internally our interface has CAS, GET-CAS-EXPANSION, DEFINE-CAS-EXPANDER,
   8 ;;;; DEFCAS, and #'(CAS ...) functions -- making things mostly isomorphic with
   9 ;;;; SETF.
  10
  11 (defglobal **cas-expanders** (make-hash-table :test #'eq :synchronized t))
  12
  13 (define-function-name-syntax cas (list)
  14   (destructuring-bind (cas symbol) list
  15     (aver (eq 'cas cas))
  16     (values t symbol)))
  17
  18 ;;; This is what it all comes down to.
  19 (def!macro cas (place old new &environment env)
  20   "Synonym for COMPARE-AND-SWAP.
  21
  22 Addtionally DEFUN, DEFGENERIC, DEFMETHOD, FLET, and LABELS can be also used to
  23 define CAS-functions analogously to SETF-functions:
  24
  25   (defvar *foo* nil)
  26
  27   (defun (cas foo) (old new)
  28     (cas (symbol-value '*foo*) old new))
  29
  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.
  34
  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)
  39             (,old-temp ,old)
  40             (,new-temp ,new))
  41        ,cas-form)))
  42
  43 (defun get-cas-expansion (place &optional environment)
  44   #!+sb-doc
  45   "Analogous to GET-SETF-EXPANSION. Returns the following six values:
  46
  47  * list of temporary variables
  48
  49  * list of value-forms whose results those variable must be bound
  50
  51  * temporary variable for the old value of PLACE
  52
  53  * temporary variable for the new value of PLACE
  54
  55  * form using the aforementioned temporaries which performs the
  56    compare-and-swap operation on PLACE
  57
  58  * form using the aforementioned temporaries with which to perform a volatile
  59    read of PLACE
  60
  61 Example:
  62
  63   (get-cas-expansion '(car x))
  64   ; => (#:CONS871), (X), #:OLD872, #:NEW873,
  65   ;    (SB-KERNEL:%COMPARE-AND-SWAP-CAR #:CONS871 #:OLD872 :NEW873).
  66   ;    (CAR #:CONS871)
  67
  68   (defmacro my-atomic-incf (place &optional (delta 1) &environment env)
  69     (multiple-value-bind (vars vals old new cas-form read-form)
  70         (get-cas-expansion place env)
  71      (let ((delta-value (gensym \"DELTA\")))
  72        `(let* (,@(mapcar 'list vars vals)
  73                (,old ,read-form)
  74                (,delta-value ,delta)
  75                (,new (+ ,old ,delta-value)))
  76           (loop until (eq ,old (setf ,old ,cas-form))
  77                 do (setf ,new (+ ,old ,delta-value)))
  78           ,new))))
  79
  80 EXPERIMENTAL: Interface subject to change."
  81   (flet ((invalid-place ()
  82            (error "Invalid place to CAS: ~S" place)))
  83     (let ((expanded (sb!xc:macroexpand place environment)))
  84       (unless (consp expanded)
  85         ;; FIXME: Allow (CAS *FOO* <OLD> <NEW>), maybe?
  86         (invalid-place))
  87       (let ((name (car expanded)))
  88         (unless (symbolp name)
  89           (invalid-place))
  90         (let ((info (gethash name **cas-expanders**)))
  91           (cond
  92             ;; CAS expander.
  93             (info
  94              (funcall info place environment))
  95
  96             ;; Structure accessor
  97             ((setf info (info :function :structure-accessor name))
  98              (expand-structure-slot-cas info name expanded))
  99
 100             ;; CAS function
 101             (t
 102              (with-unique-names (old new)
 103                (let ((vars nil)
 104                      (vals nil)
 105                      (args nil))
 106                  (dolist (x (reverse (cdr expanded)))
 107                    (cond ((constantp x environment)
 108                           (push x args))
 109                          (t
 110                           (let ((tmp (gensymify x)))
 111                             (push tmp args)
 112                             (push tmp vars)
 113                             (push x vals)))))
 114                  (values vars vals old new
 115                          `(funcall #'(cas ,name) ,old ,new ,@args)
 116                          `(,name ,@args)))))))))))
 117
 118 (defun expand-structure-slot-cas (dd name place)
 119   (let* ((structure (dd-name dd))
 120          (slotd (find name (dd-slots dd) :key #'dsd-accessor-name))
 121          (index (dsd-index slotd))
 122          (type (dsd-type slotd)))
 123     (unless (eq t (dsd-raw-type slotd))
 124       (error "Cannot use COMPARE-AND-SWAP with structure accessor ~
 125                 for a typed slot: ~S"
 126              place))
 127     (when (dsd-read-only slotd)
 128       (error "Cannot use COMPARE-AND-SWAP with structure accessor ~
 129                 for a read-only slot: ~S"
 130              place))
 131     (destructuring-bind (op arg) place
 132       (aver (eq op name))
 133       (with-unique-names (instance old new)
 134         (values (list instance)
 135                 (list arg)
 136                 old
 137                 new
 138                 `(truly-the (values ,type &optional)
 139                             (%compare-and-swap-instance-ref
 140                              (the ,structure ,instance)
 141                              ,index
 142                              (the ,type ,old)
 143                              (the ,type ,new)))
 144                 `(,op ,instance))))))
 145
 146 (def!macro define-cas-expander (accessor lambda-list &body body)
 147   "Analogous to DEFINE-SETF-EXPANDER. Defines a CAS-expansion for ACCESSOR.
 148 BODY must return six values as specified in GET-CAS-EXPANSION.
 149
 150 Note that the system provides no automatic atomicity for CAS expansion, nor
 151 can it verify that they are atomic: it is up to the implementor of a CAS
 152 expansion to ensure its atomicity.
 153
 154 EXPERIMENTAL: Interface subject to change."
 155   (with-unique-names (whole environment)
 156     (multiple-value-bind (body decls doc)
 157         (parse-defmacro lambda-list whole body accessor
 158                         'define-cas-expander
 159                         :environment environment
 160                         :wrap-block nil)
 161       `(eval-when (:compile-toplevel :load-toplevel :execute)
 162          (setf (gethash ',accessor **cas-expanders**)
 163                (lambda (,whole ,environment)
 164                  ,@(when doc (list doc))
 165                  ,@decls
 166                  ,body))))))
 167
 168 (def!macro defcas (&whole form accessor lambda-list function
 169                   &optional docstring)
 170   "Analogous to short-form DEFSETF. Defines FUNCTION as responsible
 171 for compare-and-swap on places accessed using ACCESSOR. LAMBDA-LIST
 172 must correspond to the lambda-list of the accessor.
 173
 174 Note that the system provides no automatic atomicity for CAS expansions
 175 resulting from DEFCAS, nor can it verify that they are atomic: it is up to the
 176 user of DEFCAS to ensure that the function specified is atomic.
 177
 178 EXPERIMENTAL: Interface subject to change."
 179   (multiple-value-bind (reqs opts restp rest keyp keys allowp auxp)
 180       (parse-lambda-list lambda-list)
 181     (declare (ignore keys))
 182     (when (or keyp allowp auxp)
 183       (error "&KEY, &AUX, and &ALLOW-OTHER-KEYS not allowed in DEFCAS ~
 184               lambda-list.~%  ~S" form))
 185     `(define-cas-expander ,accessor ,lambda-list
 186        ,@(when docstring (list docstring))
 187        (let ((temps (mapcar #'gensymify
 188                             ',(append reqs opts
 189                                       (when restp (list (gensymify rest))))))
 190              (args (list ,@(append reqs
 191                                    opts
 192                                    (when restp (list rest)))))
 193              (old (gensym "OLD"))
 194              (new (gensym "NEW")))
 195          (values temps
 196                  args
 197                  old
 198                  new
 199                  `(,',function ,@temps ,old ,new)
 200                  `(,',accessor ,@temps))))))
 201
 202 (def!macro compare-and-swap (place old new)
 203   #!+sb-doc
 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.
 207
 208 PLACE must be an accessor form whose CAR is one of the following:
 209
 210  CAR, CDR, FIRST, REST, SVREF, SYMBOL-PLIST, SYMBOL-VALUE, SVREF, SLOT-VALUE
 211  SB-MOP:STANDARD-INSTANCE-ACCESS, SB-MOP:FUNCALLABLE-STANDARD-INSTANCE-ACCESS,
 212
 213 or the name of a DEFSTRUCT created accessor for a slot whose declared type is
 214 either FIXNUM or T. Results are unspecified if the slot has a declared type
 215 other then FIXNUM or T.
 216
 217 In case of SLOT-VALUE, if the slot is unbound, SLOT-UNBOUND is called unless
 218 OLD is EQ to SB-PCL:+SLOT-UNBOUND+ in which case SB-PCL:+SLOT-UNBOUND+ is
 219 returned and NEW is assigned to the slot.
 220
 221 Additionally, the results are unspecified if there is an applicable method on
 222 either SB-MOP:SLOT-VALUE-USING-CLASS, (SETF SB-MOP:SLOT-VALUE-USING-CLASS), or
 223 SB-MOP:SLOT-BOUNDP-USING-CLASS.
 224
 225 EXPERIMENTAL: Interface subject to change."
 226   `(cas ,place ,old ,new))
 227
 228 ;;; Out-of-line definitions for various primitive cas functions.
 229 (macrolet ((def (name lambda-list ref &optional set)
 230              #!+compare-and-swap-vops
 231              (declare (ignore ref set))
 232              `(defun ,name (,@lambda-list old new)
 233                 #!+compare-and-swap-vops
 234                 (,name ,@lambda-list old new)
 235                 #!-compare-and-swap-vops
 236                 (progn
 237                   #!+sb-thread
 238                   ,(error "No COMPARE-AND-SWAP-VOPS on a threaded build?")
 239                   #!-sb-thread
 240                   (let ((current (,ref ,@lambda-list)))
 241                     (when (eq current old)
 242                       ,(if set
 243                            `(,set ,@lambda-list new)
 244                            `(setf (,ref ,@lambda-list) new)))
 245                     current)))))
 246   (def %compare-and-swap-car (cons) car)
 247   (def %compare-and-swap-cdr (cons) cdr)
 248   (def %compare-and-swap-instance-ref (instance index) %instance-ref %instance-set)
 249   (def %compare-and-swap-symbol-plist (symbol) symbol-plist)
 250   (def %compare-and-swap-symbol-value (symbol) symbol-value)
 251   (def %compare-and-swap-svref (vector index) svref))
 252