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     (let ((symbol (or tmp `',cname)))
  15       (with-unique-names (old new)
  16         (values (when tmp (list tmp))
  17                 (when val (list val))
  18                 old
  19                 new
  20                 (let ((slow
  21                         `(progn
  22                            (about-to-modify-symbol-value ,symbol 'compare-and-swap ,new)
  23                            (%compare-and-swap-symbol-value ,symbol ,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-value ,symbol))))))
  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))))