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 (define-cas-expander symbol-value (name &environment env)
  10   (multiple-value-bind (tmp val cname)
  11       (if (sb!xc:constantp name env)
  12           (values nil nil (constant-form-value name env))
  13           (values (gensymify name) name nil))
  14     (with-unique-names (old new)
  15       (values (when tmp (list tmp))
  16               (when val (list val))
  17               old
  18               new
  19               (let ((slow
  20                       `(locally
  21                            (declare (symbol ,tmp))
  22                          (about-to-modify-symbol-value ,tmp 'compare-and-swap ,new)
  23                          (%compare-and-swap-symbol-value ,tmp ,old ,new))))
  24                 (if cname
  25                     (if (member (info :variable :kind cname) '(:special :global))
  26                         ;; We can generate the type-check reasonably.
  27                         `(%compare-and-swap-symbol-value
  28                           ',cname ,old (the ,(info :variable :type cname) ,new))
  29                         slow)
  30                     slow))
  31               `(symbol-global-value ,(or tmp `',cname))))))
  32
  33 (define-cas-expander svref (vector index)
  34   (with-unique-names (v i old new)
  35     (values (list v i)
  36             (list vector index)
  37             old
  38             new
  39             `(locally (declare (simple-vector ,v))
  40                (%compare-and-swap-svref ,v (%check-bound ,v (length ,v) ,i) ,old ,new))
  41             `(svref ,v ,i))))