src/code/late-cas.lisp

   1 (in-package "SB!IMPL")
   2
   3 (defcas car (cons) %compare-and-swap-car)
   4 (defcas cdr (cons) %compare-and-swap-cdr)
   5 (defcas first (cons) %compare-and-swap-car)
   6 (defcas rest (cons) %compare-and-swap-cdr)
   7 (defcas symbol-plist (symbol) %compare-and-swap-symbol-plist)
   8
   9 ;;; Out-of-line definitions for various primitive cas functions.
  10 (macrolet ((def (name lambda-list ref &optional set)
  11              #!+compare-and-swap-vops
  12              (declare (ignore ref set))
  13              `(defun ,name (,@lambda-list old new)
  14                 #!+compare-and-swap-vops
  15                 (,name ,@lambda-list old new)
  16                 #!-compare-and-swap-vops
  17                 (progn
  18                   #!+sb-thread
  19                   ,(error "No COMPARE-AND-SWAP-VOPS on a threaded build?")
  20                   #!-sb-thread
  21                   (let ((current (,ref ,@lambda-list)))
  22                     ;; Shouldn't this be inside a WITHOUT-INTERRUPTS ?
  23                     (when (eq current old)
  24                       ,(if set
  25                            `(,set ,@lambda-list new)
  26                            `(setf (,ref ,@lambda-list) new)))
  27                     current)))))
  28   (def %compare-and-swap-car (cons) car)
  29   (def %compare-and-swap-cdr (cons) cdr)
  30   (def %instance-cas (instance index) %instance-ref %instance-set)
  31   #!+(or x86-64 x86)
  32   (def %raw-instance-cas/word (instance index)
  33        %raw-instance-ref/word
  34        %raw-instance-set/word)
  35   (def %compare-and-swap-symbol-info (symbol) symbol-info)
  36   (def %compare-and-swap-symbol-value (symbol) symbol-value)
  37   (def %compare-and-swap-svref (vector index) svref))
  38
  39 ;; Atomic increment/decrement ops on tagged storage cells (as contrasted with
  40 ;; specialized arrays and raw structure slots) are defined in terms of CAS.
  41
  42 ;; This code would be more concise if workable versions
  43 ;; of +-MODFX, --MODFX were defined generically.
  44 (macrolet ((modular (fun a b)
  45              #!+(or x86 x86-64)
  46              `(,(let ((*package* (find-package "SB!VM")))
  47                   (symbolicate fun "-MODFX"))
  48                 ,a ,b)
  49              #!-(or x86 x86-64)
  50              ;; algorithm of https://graphics.stanford.edu/~seander/bithacks
  51              `(let ((res (logand (,fun ,a ,b)
  52                                  (ash sb!ext:most-positive-word
  53                                       (- sb!vm:n-fixnum-tag-bits))))
  54                     (m (ash 1 (1- sb!vm:n-fixnum-bits))))
  55                 (- (logxor res m) m))))
  56
  57   ;; Atomically frob the CAR or CDR of a cons, or a symbol-value.
  58   ;; The latter will be a global value because the ATOMIC-INCF/DECF
  59   ;; macros work on a symbol only if it is known global.
  60   (macrolet ((def-frob (name op type slot)
  61                `(defun ,name (place delta)
  62                   (declare (type ,type place) (type fixnum delta))
  63                   (loop (let ((old (the fixnum (,slot place))))
  64                           (when (eq (cas (,slot place) old
  65                                          (modular ,op old delta)) old)
  66                             (return old)))))))
  67     (def-frob %atomic-inc-symbol-global-value + symbol symbol-value)
  68     (def-frob %atomic-dec-symbol-global-value - symbol symbol-value)
  69     (def-frob %atomic-inc-car + cons car)
  70     (def-frob %atomic-dec-car - cons car)
  71     (def-frob %atomic-inc-cdr + cons cdr)
  72     (def-frob %atomic-dec-cdr - cons cdr)))
  73
  74 ;;; ATOMIC-MUMBLE functions are not used when self-building.
  75
  76 (defmacro atomic-update (place update-fn &rest arguments &environment env)
  77   #!+sb-doc
  78   "Updates PLACE atomically to the value returned by calling function
  79 designated by UPDATE-FN with ARGUMENTS and the previous value of PLACE.
  80
  81 PLACE may be read and UPDATE-FN evaluated and called multiple times before the
  82 update succeeds: atomicity in this context means that the value of PLACE did
  83 not change between the time it was read, and the time it was replaced with the
  84 computed value.
  85
  86 PLACE can be any place supported by SB-EXT:COMPARE-AND-SWAP.
  87
  88 Examples:
  89
  90   ;;; Conses T to the head of FOO-LIST.
  91   (defstruct foo list)
  92   (defvar *foo* (make-foo))
  93   (atomic-update (foo-list *foo*) #'cons t)
  94
  95   (let ((x (cons :count 0)))
  96      (mapc #'sb-thread:join-thread
  97            (loop repeat 1000
  98                  collect (sb-thread:make-thread
  99                           (lambda ()
 100                             (loop repeat 1000
 101                                   do (atomic-update (cdr x) #'1+)
 102                                      (sleep 0.00001))))))
 103      ;; Guaranteed to be (:COUNT . 1000000) -- if you replace
 104      ;; atomic update with (INCF (CDR X)) above, the result becomes
 105      ;; unpredictable.
 106      x)
 107 "
 108   (multiple-value-bind (vars vals old new cas-form read-form)
 109       (get-cas-expansion place env)
 110     `(let* (,@(mapcar 'list vars vals)
 111             (,old ,read-form))
 112        (loop for ,new = (funcall ,update-fn ,@arguments ,old)
 113              until (eq ,old (setf ,old ,cas-form))
 114              finally (return ,new)))))
 115
 116 (defmacro atomic-push (obj place &environment env)
 117   #!+sb-doc
 118   "Like PUSH, but atomic. PLACE may be read multiple times before
 119 the operation completes -- the write does not occur until such time
 120 that no other thread modified PLACE between the read and the write.
 121
 122 Works on all CASable places."
 123   (multiple-value-bind (vars vals old new cas-form read-form)
 124       (get-cas-expansion place env)
 125     `(let* (,@(mapcar 'list vars vals)
 126             (,old ,read-form)
 127             (,new (cons ,obj ,old)))
 128        (loop until (eq ,old (setf ,old ,cas-form))
 129              do (setf (cdr ,new) ,old)
 130              finally (return ,new)))))
 131
 132 (defmacro atomic-pop (place &environment env)
 133   #!+sb-doc
 134   "Like POP, but atomic. PLACE may be read multiple times before
 135 the operation completes -- the write does not occur until such time
 136 that no other thread modified PLACE between the read and the write.
 137
 138 Works on all CASable places."
 139   (multiple-value-bind (vars vals old new cas-form read-form)
 140       (get-cas-expansion place env)
 141     `(let* (,@(mapcar 'list vars vals))
 142        (loop for ,old = ,read-form
 143              for ,new = (cdr ,old)
 144              until (eq ,old (setf ,old ,cas-form))
 145              finally (return (car ,old))))))