CAS elements of (unsigned-byte 64) words on SBCL

cas-words.lisp

(defpackage cas-word
  (:use :cl)
  (:export #:word-ref #:run-tests))

(in-package :sb-vm)

(sb-c:defknown cas-word::%cas-word
    ((simple-array (unsigned-byte 64) 1) fixnum (unsigned-byte 64) (unsigned-byte 64))
    (unsigned-byte 64)
    ()
  :overwrite-fndb-silently t)

(define-vop (cas-word::%cas-word)
  (:translate cas-word::%cas-word)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg) :to :eval)
         (index :scs (any-reg immediate) :to :eval)
         (old-value :scs (unsigned-reg))
         (new-value :scs (unsigned-reg)))
  (:arg-types simple-array-unsigned-byte-64 tagged-num unsigned-num unsigned-num)
  (:temporary (:sc unsigned-reg :offset rax-offset
               :from (:argument 1) :to :result :target value)
              rax)
  (:results (value :scs (unsigned-reg)))
  (:result-types unsigned-byte-64)
  (:generator 5
              (move rax old-value)
              (inst cmpxchg :qword
                    (ea (- (* (+ (if (sc-is index immediate) (tn-value index) 0)
                                 vector-data-offset)
                              n-word-bytes)
                           other-pointer-lowtag)
                        object
                        (unless (sc-is index immediate) index)
                        (ash 1 (- word-shift n-fixnum-tag-bits)))
                    new-value :lock)
              (move value rax)))

(in-package :cas-word)

(defun %cas-word (word-vector index old new)
  (%cas-word word-vector index old new))

(defun cas-word (word-vector index old new)
  (declare ((simple-array (unsigned-byte 64) 1) word-vector)
           ((unsigned-byte 64) old new)
           (optimize (speed 3) (safety 1)))
  (%cas-word word-vector
             (sb-kernel:check-bound word-vector (length word-vector) index)
             old new))

(sb-ext:define-cas-expander word-ref (vector index)
  (sb-impl::with-unique-names (v i old new)
    (values (list v i)
            (list vector index)
            old
            new
            `(locally
                 (declare ((simple-array (unsigned-byte 64) 1) ,v))
               (%cas-word ,v (sb-kernel:check-bound ,v (length ,v) ,i) ,old ,new))
            `(aref ,v ,i))))

;; Now some tests.

(defun make-word-vector (length)
  (make-array length
              :element-type '(unsigned-byte 64)
              :initial-element 0))

(parachute:define-test some-tests
  (let ((v (make-word-vector 10)))
    (parachute:true
     (atomics:cas (word-ref v 1) 0 3))
    (parachute:true
     (atomics:cas (word-ref v 1) 3 5))
    (parachute:false
     (atomics:cas (word-ref v 1) 4 0))
    (parachute:fail
     (atomics:cas (word-ref v 123) 0 1))))
(defun run-tests ()
  (parachute:test 'some-tests))