src/code/cas.lisp

   1 (in-package "SB-IMPL")
   2
   3 (declaim (inline (cas car) (cas cdr) (cas first) (cas rest)))
   4 (defun (cas car) (old new cons) (%compare-and-swap-car cons old new))
   5 (defun (cas cdr) (old new cons) (%compare-and-swap-cdr cons old new))
   6 (defun (cas first) (old new cons) (%compare-and-swap-car cons old new))
   7 (defun (cas rest) (old new cons) (%compare-and-swap-cdr cons old new))
   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   ;; %instance-set is OK here even though it doesn't return a value
  31   ;; because it is used for effect. And if compare-and-swap vops exist,
  32   ;; then the setter isn't used at all.
  33   (def %instance-cas (instance index) %instance-ref %instance-set)
  34   #+(or x86-64 x86 riscv)
  35   (def %raw-instance-cas/word (instance index)
  36        %raw-instance-ref/word
  37        %raw-instance-set/word)
  38   #+(or arm64 riscv x86 x86-64)
  39   (def %raw-instance-cas/signed-word (instance index)
  40        %raw-instance-ref/signed-word
  41        %raw-instance-set/signed-word)
  42   (def %compare-and-swap-symbol-value (symbol) symbol-value)
  43   (def %compare-and-swap-svref (vector index) svref))
  44
  45 ;; Atomic increment/decrement ops on tagged storage cells (as contrasted with
  46 ;; specialized arrays and raw structure slots) are defined in terms of CAS.
  47
  48 ;; This code would be more concise if workable versions
  49 ;; of +-MODFX, --MODFX were defined generically.
  50 (macrolet ((modular (fun a b)
  51              #+(or x86 x86-64)
  52              `(,(package-symbolicate "SB-VM" fun "-MODFX") ,a ,b)
  53              #-(or x86 x86-64)
  54              ;; algorithm of https://graphics.stanford.edu/~seander/bithacks
  55              `(let ((res (logand (,fun ,a ,b)
  56                                  (ash sb-ext:most-positive-word
  57                                       (- sb-vm:n-fixnum-tag-bits))))
  58                     (m (ash 1 (1- sb-vm:n-fixnum-bits))))
  59                 (- (logxor res m) m))))
  60
  61   ;; Atomically frob the CAR or CDR of a cons, or a symbol-value.
  62   ;; The latter will be a global value because the ATOMIC-INCF/DECF
  63   ;; macros work on a symbol only if it is known global.
  64   (macrolet ((def-frob (name op type slot)
  65                `(defun ,name (place delta)
  66                   (declare (type ,type place) (type fixnum delta))
  67                   (loop (let ((old (the fixnum (,slot place))))
  68                           (when (eq (cas (,slot place) old
  69                                          (modular ,op old delta)) old)
  70                             (return old)))))))
  71     (def-frob %atomic-inc-symbol-global-value + symbol symbol-value)
  72     (def-frob %atomic-dec-symbol-global-value - symbol symbol-value)
  73     (def-frob %atomic-inc-car + cons car)
  74     (def-frob %atomic-dec-car - cons car)
  75     (def-frob %atomic-inc-cdr + cons cdr)
  76     (def-frob %atomic-dec-cdr - cons cdr)))