1 ;;;; Lock-free FIFO queues, from "An Optimistic Approach to Lock-Free FIFO
2 ;;;; Queues" by Edya Ladan-Mozes and Nir Shavit.
4 ;;;; Written by Nikodemus Siivola for SBCL.
6 ;;;; This software is part of the SBCL system. See the README file for
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.
14 (in-package :sb-concurrency)
16 (defconstant +dummy+ '.dummy.)
18 (declaim (inline make-node))
21 (prev nil :type (or null node))
22 (next nil :type (or null node)))
24 (declaim (inline %make-queue))
25 (defstruct (queue (:constructor %make-queue (head tail name))
28 "Lock-free thread safe FIFO queue.
30 Use ENQUEUE to add objects to the queue, and DEQUEUE to remove them."
31 (head (error "No HEAD.") :type node)
32 (tail (error "No TAIL.") :type node)
35 (setf (documentation 'queuep 'function)
36 "Returns true if argument is a QUEUE, NIL otherwise."
37 (documentation 'queue-name 'function)
38 "Name of a QUEUE. Can be assingned to using SETF. Queue names
39 can be arbitrary printable objects, and need not be unique.")
41 (defun make-queue (&key name initial-contents)
42 "Returns a new QUEUE with NAME and contents of the INITIAL-CONTENTS
44 (let* ((dummy (make-node :value +dummy+))
45 (queue (%make-queue dummy dummy name)))
48 (declare (dynamic-extent #'enc-1))
49 (map nil #'enc-1 initial-contents))
52 (defun enqueue (value queue)
53 "Adds VALUE to the end of QUEUE. Returns VALUE."
54 (let ((node (make-node :value value)))
55 (loop for tail = (queue-tail queue)
56 do (setf (node-next node) tail)
57 (when (eq tail (sb-ext:compare-and-swap (queue-tail queue) tail node))
58 (setf (node-prev tail) node)
61 (defun dequeue (queue)
62 "Retrieves the oldest value in QUEUE and returns it as the primary value,
63 and T as secondary value. If the queue is empty, returns NIL as both primary
67 (let* ((head (queue-head queue))
68 (tail (queue-tail queue))
69 (first-node-prev (node-prev head))
70 (val (node-value head)))
72 (when (eq head (queue-head queue))
73 (cond ((not (eq val +dummy+))
75 (let ((dummy (make-node :value +dummy+ :next tail)))
76 (when (eq tail (sb-ext:compare-and-swap (queue-tail queue)
78 (setf (node-prev head) dummy))
80 (when (null first-node-prev)
81 (fixList queue tail head)
83 (when (eq head (sb-ext:compare-and-swap (queue-head queue)
84 head first-node-prev))
85 ;; These assignment is not present in the paper, but are
86 ;; equivalent to the free(head.ptr) call there.
88 ;; First we unlink the HEAD from the queue -- the code in
89 ;; the paper leaves the dangling pointer in place.
91 ;; Then we NIL out the slots in HEAD to help the GC,
92 ;; otherwise conservativism might lead to massive chains of
93 ;; nodes being retained.
94 (setf (node-next first-node-prev) nil
97 (node-value head) nil)
98 (return-from dequeue (values val t))))
100 (return-from dequeue (values nil nil)))
101 ((null first-node-prev)
102 (fixList queue tail head)
105 (sb-ext:compare-and-swap (queue-head queue)
106 head first-node-prev)))))
109 (defun fixlist (queue tail head)
110 (let ((current tail))
111 (loop while (and (eq head (queue-head queue)) (not (eq current head)))
112 do (let ((next (node-next current)))
114 (return-from fixlist nil))
115 (let ((nextNodePrev (node-prev next)))
116 (when (not (eq nextNodePrev current))
117 (setf (node-prev next) current))
118 (setf current next))))))
120 (defun list-queue-contents (queue)
121 "Returns the contents of QUEUE as a list without removing them from the
122 QUEUE. Mainly useful for manual examination of queue state, as the list
123 may be out of date by the time it is returned."
125 (labels ((walk (node)
126 ;; Since NEXT pointers are always right, traversing from tail
128 (let ((value (node-value node))
129 (next (node-next node)))
130 (unless (eq +dummy+ value)
134 (walk (queue-tail queue)))
137 (defun queue-count (queue)
138 "Returns the number of objects in QUEUE. Mainly useful for manual
139 examination of queue state, and in PRINT-OBJECT methods: inefficient as it
140 must walk the entire queue."
142 (declare (unsigned-byte n))
143 (labels ((walk (node)
144 (let ((value (node-value node))
145 (next (node-next node)))
146 (unless (eq +dummy+ value)
150 (walk (queue-tail queue))
153 (defun queue-empty-p (queue)
154 "Returns T if QUEUE is empty, NIL otherwise."
155 (let* ((head (queue-head queue))
156 (tail (queue-tail queue))
157 (val (node-value head)))
158 (and (eq head tail) (eq val +dummy+))))