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