Fix typos in docstrings and function names.

[sbcl.git] / contrib / sb-concurrency / queue.lisp

diff --git a/contrib/sb-concurrency/queue.lisp b/contrib/sb-concurrency/queue.lisp
index a902785..4ffe171 100644 (file)
--- a/contrib/sb-concurrency/queue.lisp
+++ b/contrib/sb-concurrency/queue.lisp
@@ -1,7 +1,5 @@
-;;;; Lock-free FIFO queues, from "An Optimistic Approach to Lock-Free FIFO
-;;;; Queues" by Edya Ladan-Mozes and Nir Shavit.
-;;;;
-;;;; Written by Nikodemus Siivola for SBCL.
+;;;; Written by James M. Lawrence for SBCL.
+;;;; API and docstrings by Nikodemus Siivola.

 ;;;;
 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; more information.
 ;;;;
 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; more information.

@@ -11,35 +9,49 @@
 ;;;; software is in the public domain and is provided with absolutely no
 ;;;; warranty. See the COPYING and CREDITS files for more information.
 
 ;;;; software is in the public domain and is provided with absolutely no
 ;;;; warranty. See the COPYING and CREDITS files for more information.
 

+;;; Singly-linked queue with compare-and-swap operations.
+;;;
+;;; The following invariants hold except during updates:
+;;;
+;;;   (car (queue-head queue)) == +dummy+
+;;;
+;;;   (cdr (queue-tail queue)) == nil
+;;;
+;;;   If the queue is empty, (queue-head queue) == (queue-tail queue).
+;;;
+;;;   If the queue is non-empty, (cadr (queue-head queue)) is the next
+;;;   value to be dequeued and (car (queue-tail queue)) is the most
+;;;   recently enqueued value.
+;;;
+;;; The CDR of a discarded node is set to +DEAD-END+. This flag must
+;;; be checked at each traversal.
+

 (in-package :sb-concurrency)
 
 (defconstant +dummy+ '.dummy.)
 (in-package :sb-concurrency)
 
 (defconstant +dummy+ '.dummy.)

-
-(declaim (inline make-node))
-(defstruct node
-  value
-  (prev nil :type (or null node))
-  (next nil :type (or null node)))
+(defconstant +dead-end+ '.dead-end.)

 
 (declaim (inline %make-queue))
 (defstruct (queue (:constructor %make-queue (head tail name))
                   (:copier nil)
                   (:predicate queuep))
 
 (declaim (inline %make-queue))
 (defstruct (queue (:constructor %make-queue (head tail name))
                   (:copier nil)
                   (:predicate queuep))

-  "Lock-free thread safe queue."
-  (head (error "No HEAD.") :type node)
-  (tail (error "No TAIL.") :type node)
+  "Lock-free thread safe FIFO queue.
+
+Use ENQUEUE to add objects to the queue, and DEQUEUE to remove them."
+  (head (error "No HEAD.") :type cons)
+  (tail (error "No TAIL.") :type cons)

   (name nil))
 
 (setf (documentation 'queuep 'function)
       "Returns true if argument is a QUEUE, NIL otherwise."
       (documentation 'queue-name 'function)
   (name nil))
 
 (setf (documentation 'queuep 'function)
       "Returns true if argument is a QUEUE, NIL otherwise."
       (documentation 'queue-name 'function)

-      "Name of a QUEUE. Can be assingned to using SETF. Queue names
+      "Name of a QUEUE. Can be assignned to using SETF. Queue names

 can be arbitrary printable objects, and need not be unique.")
 
 (defun make-queue (&key name initial-contents)
   "Returns a new QUEUE with NAME and contents of the INITIAL-CONTENTS
 sequence enqueued."
 can be arbitrary printable objects, and need not be unique.")
 
 (defun make-queue (&key name initial-contents)
   "Returns a new QUEUE with NAME and contents of the INITIAL-CONTENTS
 sequence enqueued."

-  (let* ((dummy (make-node :value +dummy+))
+  (let* ((dummy (cons +dummy+ nil))

          (queue (%make-queue dummy dummy name)))
     (flet ((enc-1 (x)
              (enqueue x queue)))
          (queue (%make-queue dummy dummy name)))
     (flet ((enc-1 (x)
              (enqueue x queue)))

@@ -49,99 +61,76 @@ sequence enqueued."
 
 (defun enqueue (value queue)
   "Adds VALUE to the end of QUEUE. Returns VALUE."
 
 (defun enqueue (value queue)
   "Adds VALUE to the end of QUEUE. Returns VALUE."

-  (let ((node (make-node :value value)))
-    (loop for tail = (queue-tail queue)
-          do (setf (node-next node) tail)
-             (when (eq tail (sb-ext:compare-and-swap (queue-tail queue) tail node))
-               (setf (node-prev tail) node)
-               (return value)))))
+  ;; Attempt CAS, repeat upon failure. Upon success update QUEUE-TAIL.
+  (declare (optimize speed))
+  (let ((new (cons value nil)))
+    (loop (when (eq nil (sb-ext:compare-and-swap (cdr (queue-tail queue))
+                                                 nil new))
+            (setf (queue-tail queue) new)
+            (return value)))))

 
 (defun dequeue (queue)
   "Retrieves the oldest value in QUEUE and returns it as the primary value,
 and T as secondary value. If the queue is empty, returns NIL as both primary
 and secondary value."
 
 (defun dequeue (queue)
   "Retrieves the oldest value in QUEUE and returns it as the primary value,
 and T as secondary value. If the queue is empty, returns NIL as both primary
 and secondary value."

-  (tagbody
-   :continue
-     (let* ((head (queue-head queue))
-            (tail (queue-tail queue))
-            (first-node-prev (node-prev head))
-            (val (node-value head)))
-       (barrier (:read))
-       (when (eq head (queue-head queue))
-         (cond ((not (eq val +dummy+))
-                (if (eq tail head)
-                    (let ((dummy (make-node :value +dummy+ :next tail)))
-                      (when (eq tail (sb-ext:compare-and-swap (queue-tail queue)
-                                                              tail dummy))
-                        (setf (node-prev head) dummy))
-                      (go :continue))
-                    (when (null first-node-prev)
-                      (fixList queue tail head)
-                      (go :continue)))
-                (when (eq head (sb-ext:compare-and-swap (queue-head queue)
-                                                        head first-node-prev))
-                  ;; This assignment is not present in the paper, but is
-                  ;; equivalent to the free(head.ptr) call there: it unlinks
-                  ;; the HEAD from the queue -- the code in the paper leaves
-                  ;; the dangling pointer in place.
-                  (setf (node-next first-node-prev) nil)
-                  (return-from dequeue (values val t))))
-               ((eq tail head)
-                (return-from dequeue (values nil nil)))
-               ((null first-node-prev)
-                (fixList queue tail head)
-                (go :continue))
-               (t
-                (sb-ext:compare-and-swap (queue-head queue)
-                                         head first-node-prev)))))
-     (go :continue)))
+  ;; Attempt to CAS QUEUE-HEAD with the next node, repeat upon
+  ;; failure. Upon success, clear the discarded node and set the CAR
+  ;; of QUEUE-HEAD to +DUMMY+.
+  (declare (optimize speed))
+  (loop (let* ((head (queue-head queue))
+               (next (cdr head)))
+          ;; NEXT could be +DEAD-END+, whereupon we try again.
+          (typecase next
+            (null (return (values nil nil)))
+            (cons (when (eq head (sb-ext:compare-and-swap (queue-head queue)
+                                                          head next))
+                    (let ((value (car next)))
+                      ;; Clear the CDR, otherwise the conservative GC could
+                      ;; hoard long lists. (car head) is always +dummy+.
+                      (setf (cdr head) +dead-end+
+                            (car next) +dummy+)
+                      (return (values value t)))))))))

 
 

-(defun fixlist (queue tail head)
-  (let ((current tail))
-    (loop while (and (eq head (queue-head queue)) (not (eq current head)))
-          do (let ((next (node-next current)))
-               (when (not next)
-                 (return-from fixlist nil))
-               (let ((nextNodePrev (node-prev next)))
-                 (when (not (eq nextNodePrev current))
-                   (setf (node-prev next) current))
-                 (setf current next))))))
+(defun try-walk-queue (fun queue)
+  ;; This isn't /quite/ as bad as it looks. We're in danger of needing
+  ;; to restart only as long as we're close to the head of the queue.
+  (let ((node (queue-head queue)))
+    (loop
+       (let ((value (car node)))
+         (unless (eq value +dummy+)
+           (funcall fun value)))
+       (setf node (cdr node))
+       (cond ((eq node +dead-end+)
+              (return nil))
+             ((null node)
+              (return t))))))

 
 (defun list-queue-contents (queue)
   "Returns the contents of QUEUE as a list without removing them from the
 
 (defun list-queue-contents (queue)
   "Returns the contents of QUEUE as a list without removing them from the

-QUEUE. Mainly useful for manual examination of queue state."
-  (let (all)
-    (labels ((walk (node)
-               ;; Since NEXT pointers are always right, traversing from tail
-               ;; to head is safe.
-               (let ((value (node-value node))
-                     (next (node-next node)))
-                 (unless (eq +dummy+ value)
-                   (push value all))
-                 (when next
-                   (walk next)))))
-      (walk (queue-tail queue)))
-    all))
+QUEUE. Mainly useful for manual examination of queue state, as the list may be
+out of date by the time it is returned, and concurrent dequeue operations may
+in the worse case force the queue-traversal to be restarted several times."
+  (tagbody
+   :retry
+     (collect ((result))
+       (unless (try-walk-queue (lambda (elem) (result elem)) queue)
+         (go :retry))
+       (return-from list-queue-contents (result)))))

 
 (defun queue-count (queue)
   "Returns the number of objects in QUEUE. Mainly useful for manual
 examination of queue state, and in PRINT-OBJECT methods: inefficient as it
 
 (defun queue-count (queue)
   "Returns the number of objects in QUEUE. Mainly useful for manual
 examination of queue state, and in PRINT-OBJECT methods: inefficient as it

-walks the entire queue."
-  (let ((n 0))
-    (declare (unsigned-byte n))
-    (labels ((walk (node)
-               (let ((value (node-value node))
-                     (next (node-next node)))
-                 (unless (eq +dummy+ value)
-                   (incf n))
-                 (when next
-                   (walk next)))))
-      (walk (queue-tail queue))
-      n)))
+must walk the entire queue."
+  (tagbody
+   :retry
+     (let ((count 0))
+       (unless (try-walk-queue (lambda (elem)
+                                 (declare (ignore elem))
+                                 (incf count))
+                               queue)
+         (go :retry))
+       (return-from queue-count count))))

 
 (defun queue-empty-p (queue)
   "Returns T if QUEUE is empty, NIL otherwise."
 
 (defun queue-empty-p (queue)
   "Returns T if QUEUE is empty, NIL otherwise."

-  (let* ((head (queue-head queue))
-         (tail (queue-tail queue))
-         (val (node-value head)))
-    (and (eq head tail) (eq val +dummy+))))
+  (null (cdr (queue-head queue))))