lock-free stack in common lisp

cas-stack.lisp

(defpackage :cas-stack
  (:use :common-lisp)
  (:export
   :make-stack
   :stack-push
   :stack-pop))

(in-package :cas-stack)

;; https://github.com/zerth/cl-cas-queue/blob/master/cas-queue.lisp
(defconstant +cas-sleep+ (/ 1 internal-time-units-per-second)
  "The initial duration in seconds for which a thread should sleep
while in a CAS retry loop.")

;; https://github.com/zerth/cl-cas-queue/blob/master/cas-queue.lisp
(defconstant +max-cas-sleep+ 0.1
  "The maximum duration in seconds for which a thread in a CAS retry
loop should sleep.")


;; https://github.com/zerth/cl-cas-queue/blob/master/cas-queue.lisp
(defmacro cas (place old new)
  "Atomically attempt to set the new value of PLACE to be NEW if it
was EQ to OLD, returning non-nil if successful."
  #+lispworks `(sys:compare-and-swap ,place ,old ,new)
  #+ccl `(ccl::conditional-store ,place ,old ,new)
  #+sbcl (let ((ov (gensym "OLD")))
           `(let ((,ov ,old))
              (eq ,ov (sb-ext:compare-and-swap ,place ,ov ,new))))
  #-(or lispworks ccl sbcl) (error "fixme; implement CAS"))

;; https://github.com/zerth/cl-cas-queue/blob/master/cas-queue.lisp
(defmacro atomic-incf (place)
  "Atomically increment the value of PLACE.  For CCL, SBCL, and LW, it
should be an accessor form for a struct slot holding an integer."
  #+lispworks `(sys:atomic-incf ,place)
  #+ccl `(ccl::atomic-incf ,place)
  #+sbcl `(sb-ext:atomic-incf ,place)
  #-(or lispworks ccl sbcl) (error "fixme; implement ATOMIC-INCF"))

(defmacro atomic-decf (place)
  "Atomically decrement the value of PLACE.  For CCL, SBCL, and LW, it
should be an accessor form for a struct slot holding an integer."
  #+lispworks `(sys:atomic-decf ,place)
  #+ccl `(ccl::atomic-decf ,place)
  #+sbcl `(sb-ext:atomic-decf ,place)
  #-(or lispworks ccl sbcl) (error "fixme; implement ATOMIC-DECF"))

;; https://github.com/zerth/cl-cas-queue/blob/master/cas-queue.lisp
(defmacro with-cas-retry (&body forms)
  "Execute FORMS with RETRY lexically bound to a function which sleeps
for the current CAS sleep interval before retrying FORMS.  The sleep
interval starts at +CAS-SLEEP+ and exponentially increases up to
+MAX-CAS-SLEEP+."
  (let ((b (gensym "BLOCK"))
        (r (gensym "RETRY"))
        (f (gensym "F"))
        (w (gensym "WAITTIME")))
    `(let ((,w +cas-sleep+))
       (block ,b
         (tagbody
          ,r
          (flet ((retry ()
                   (sleep ,w)
                   (setq ,w (min +max-cas-sleep+
                                 (* 1.5 ,w)))
                   (go ,r)))
            (flet ((,f () ,@forms))
              (return-from ,b (,f)))))))))


(defstruct node
  data
  next)

(defstruct stack
  (root nil)
  (count 0 :type sb-ext:word))

(defun stack-push (stack value)
  (let ((new-root (make-node :data value)))
    (with-cas-retry
        (let ((old-root (stack-root stack)))
          (setf (node-next new-root) old-root)
          (unless (cas (stack-root stack) old-root new-root)
            (retry))))
    (atomic-incf (stack-count stack))))

(defun stack-pop (stack)
  (let ((old-root (stack-root stack)))
    (with-cas-retry
        (let ((new-root (node-next old-root)))
          (unless (cas (stack-root stack) old-root new-root)
            (retry))))
    (atomic-decf (stack-count stack))
    (node-data old-root)))