X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-concurrency%2Fqueue.lisp;h=4ffe171303e149bee2d6850bb2406fcbb43d14b5;hb=54da325f13fb41669869aea688ae195426c0e231;hp=a902785cbdfd9f90edb65d5b8a020afae5c31080;hpb=713bb89f472457ec6654732b6b248b17b971f0ff;p=sbcl.git diff --git a/contrib/sb-concurrency/queue.lisp b/contrib/sb-concurrency/queue.lisp index a902785..4ffe171 100644 --- 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. @@ -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. +;;; 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.) - -(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)) - "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 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." - (let* ((dummy (make-node :value +dummy+)) + (let* ((dummy (cons +dummy+ nil)) (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." - (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." - (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 -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 -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." - (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))))