contrib/sb-queue/sb-queue.lisp

   1 ;;;; Lock-free FIFO queues, from "An Optimistic Approach to Lock-Free FIFO
   2 ;;;; Queues" by Edya Ladan-Mozes and Nir Shavit.
   3 ;;;;
   4 ;;;; Written by Nikodemus Siivola for SBCL.
   5 ;;;;
   6 ;;;; This software is part of the SBCL system. See the README file for
   7 ;;;; more information.
   8 ;;;;
   9 ;;;; This software is derived from the CMU CL system, which was written at
  10 ;;;; Carnegie Mellon University and released into the public domain. The
  11 ;;;; software is in the public domain and is provided with absolutely no
  12 ;;;; warranty. See the COPYING and CREDITS files for more information.
  13
  14 (defpackage :sb-queue
  15   (:use :cl :sb-thread :sb-sys :sb-ext)
  16   (:export
  17    "DEQUEUE"
  18    "ENQUEUE"
  19    "LIST-QUEUE-CONTENTS"
  20    "MAKE-QUEUE"
  21    "QUEUE"
  22    "QUEUE-COUNT"
  23    "QUEUE-EMPTY-P"
  24    "QUEUE-NAME"
  25    "QUEUEP"))
  26
  27 (in-package :sb-queue)
  28
  29 (defconstant +dummy+ '.dummy.)
  30
  31 (declaim (inline make-node))
  32 (defstruct node
  33   value
  34   (prev nil :type (or null node))
  35   (next nil :type (or null node)))
  36
  37 (declaim (inline %make-queue))
  38 (defstruct (queue (:constructor %make-queue (head tail name))
  39                   (:copier nil)
  40                   (:predicate queuep))
  41   "Lock-free thread safe queue. ENQUEUE can be used to add objects to the queue,
  42 and DEQUEUE retrieves items from the queue in FIFO order."
  43   (head (error "No HEAD.") :type node)
  44   (tail (error "No TAIL.") :type node)
  45   (name nil))
  46
  47 (setf (documentation 'queuep 'function)
  48       "Returns true if argument is a QUEUE, NIL otherwise."
  49       (documentation 'queue-name 'function)
  50       "Name of a QUEUE. Can be assingned to using SETF. Queue names
  51 can be arbitrary printable objects, and need not be unique.")
  52
  53 (defun make-queue (&key name initial-contents)
  54   "Returns a new QUEUE with NAME and contents of the INITIAL-CONTENTS
  55 sequence enqueued."
  56   (let* ((dummy (make-node :value +dummy+))
  57          (queue (%make-queue dummy dummy name)))
  58     (flet ((enc-1 (x)
  59              (enqueue x queue)))
  60       (declare (dynamic-extent #'enc-1))
  61       (map nil #'enc-1 initial-contents))
  62     queue))
  63
  64 (defun enqueue (value queue)
  65   "Adds VALUE to the end of QUEUE. Returns VALUE."
  66   (let ((node (make-node :value value)))
  67     (loop for tail = (queue-tail queue)
  68           do (setf (node-next node) tail)
  69              (when (eq tail (sb-ext:compare-and-swap (queue-tail queue) tail node))
  70                (setf (node-prev tail) node)
  71                (return value)))))
  72
  73 (defun dequeue (queue)
  74   "Retrieves the oldest value in QUEUE and returns it as the primary value,
  75 and T as secondary value. If the queue is empty, returns NIL as both primary
  76 and secondary value."
  77   (tagbody
  78    :continue
  79      (let* ((head (queue-head queue))
  80             (tail (queue-tail queue))
  81             (first-node-prev (node-prev head))
  82             (val (node-value head)))
  83        (when (eq head (queue-head queue))
  84          (cond ((not (eq val +dummy+))
  85                 (if (eq tail head)
  86                     (let ((dummy (make-node :value +dummy+ :next tail)))
  87                       (when (eq tail (sb-ext:compare-and-swap (queue-tail queue)
  88                                                               tail dummy))
  89                         (setf (node-prev head) dummy))
  90                       (go :continue))
  91                     (when (null first-node-prev)
  92                       (fixList queue tail head)
  93                       (go :continue)))
  94                 (when (eq head (sb-ext:compare-and-swap (queue-head queue)
  95                                                         head first-node-prev))
  96                   ;; This assignment is not present in the paper, but is
  97                   ;; equivalent to the free(head.ptr) call there: it unlinks
  98                   ;; the HEAD from the queue -- the code in the paper leaves
  99                   ;; the dangling pointer in place.
 100                   (setf (node-next first-node-prev) nil)
 101                   (return-from dequeue (values val t))))
 102                ((eq tail head)
 103                 (return-from dequeue (values nil nil)))
 104                ((null first-node-prev)
 105                 (fixList queue tail head)
 106                 (go :continue))
 107                (t
 108                 (sb-ext:compare-and-swap (queue-head queue)
 109                                          head first-node-prev)))))
 110      (go :continue)))
 111
 112 (defun fixlist (queue tail head)
 113   (let ((current tail))
 114     (loop while (and (eq head (queue-head queue)) (not (eq current head)))
 115           do (let ((next (node-next current)))
 116                (when (not next)
 117                  (return-from fixlist nil))
 118                (let ((nextNodePrev (node-prev next)))
 119                  (when (not (eq nextNodePrev current))
 120                    (setf (node-prev next) current))
 121                  (setf current next))))))
 122
 123 (defun list-queue-contents (queue)
 124   "Returns the contents of QUEUE as a list without removing them from the
 125 QUEUE. Mainly useful for manual examination of queue state."
 126   (let (all)
 127     (labels ((walk (node)
 128                ;; Since NEXT pointers are always right, traversing from tail
 129                ;; to head is safe.
 130                (let ((value (node-value node))
 131                      (next (node-next node)))
 132                  (unless (eq +dummy+ value)
 133                    (push value all))
 134                  (when next
 135                    (walk next)))))
 136       (walk (queue-tail queue)))
 137     all))
 138
 139 (defun queue-count (queue)
 140   "Returns the number of objects in QUEUE. Mainly useful for manual
 141 examination of queue state, and in PRINT-OBJECT methods: inefficient as it
 142 walks the entire queue."
 143   (let ((n 0))
 144     (declare (unsigned-byte n))
 145     (labels ((walk (node)
 146                (let ((value (node-value node))
 147                      (next (node-next node)))
 148                  (unless (eq +dummy+ value)
 149                    (incf n))
 150                  (when next
 151                    (walk next)))))
 152       (walk (queue-tail queue))
 153       n)))
 154
 155 (defun queue-empty-p (queue)
 156   "Returns T if QUEUE is empty, NIL otherwise."
 157   (let* ((head (queue-head queue))
 158          (tail (queue-tail queue))
 159          (val (node-value head)))
 160     (and (eq head tail) (eq val +dummy+))))
 161
 162 (provide :sb-queue)