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   "Updates PLACE atomically to the value returned by calling function
  78 designated by UPDATE-FN with ARGUMENTS and the previous value of PLACE.
  79
  80 PLACE may be read and UPDATE-FN evaluated and called multiple times before the
  81 update succeeds: atomicity in this context means that the value of PLACE did
  82 not change between the time it was read, and the time it was replaced with the
  83 computed value.
  84
  85 PLACE can be any place supported by SB-EXT:COMPARE-AND-SWAP.
  86
  87 Examples:
  88
  89   ;;; Conses T to the head of FOO-LIST.
  90   (defstruct foo list)
  91   (defvar *foo* (make-foo))
  92   (atomic-update (foo-list *foo*) #'cons t)
  93
  94   (let ((x (cons :count 0)))
  95      (mapc #'sb-thread:join-thread
  96            (loop repeat 1000
  97                  collect (sb-thread:make-thread
  98                           (lambda ()
  99                             (loop repeat 1000
 100                                   do (atomic-update (cdr x) #'1+)
 101                                      (sleep 0.00001))))))
 102      ;; Guaranteed to be (:COUNT . 1000000) -- if you replace
 103      ;; atomic update with (INCF (CDR X)) above, the result becomes
 104      ;; unpredictable.
 105      x)
 106 "
 107   (multiple-value-bind (vars vals old new cas-form read-form)
 108       (get-cas-expansion place env)
 109     `(let* (,@(mapcar 'list vars vals)
 110             (,old ,read-form))
 111        (loop for ,new = (funcall ,update-fn ,@arguments ,old)
 112              until (eq ,old (setf ,old ,cas-form))
 113              finally (return ,new)))))
 114
 115 (defmacro atomic-push (obj place &environment env)
 116   "Like PUSH, but atomic. PLACE may be read multiple times before
 117 the operation completes -- the write does not occur until such time
 118 that no other thread modified PLACE between the read and the write.
 119
 120 Works on all CASable places."
 121   (multiple-value-bind (vars vals old new cas-form read-form)
 122       (get-cas-expansion place env)
 123     `(let* (,@(mapcar 'list vars vals)
 124             (,old ,read-form)
 125             (,new (cons ,obj ,old)))
 126        (loop until (eq ,old (setf ,old ,cas-form))
 127              do (setf (cdr ,new) ,old)
 128              finally (return ,new)))))
 129
 130 (defmacro atomic-pop (place &environment env)
 131   "Like POP, but atomic. PLACE may be read multiple times before
 132 the operation completes -- the write does not occur until such time
 133 that no other thread modified PLACE between the read and the write.
 134
 135 Works on all CASable places."
 136   (multiple-value-bind (vars vals old new cas-form read-form)
 137       (get-cas-expansion place env)
 138     `(let* (,@(mapcar 'list vars vals))
 139        (loop for ,old = ,read-form
 140              for ,new = (cdr ,old)
 141              until (eq ,old (setf ,old ,cas-form))
 142              finally (return (car ,old))))))