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