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