+++ /dev/null
-;;;; 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.
-;;;;
-;;;; This software is part of the SBCL system. See the README file for
-;;;; more information.
-;;;;
-;;;; This software is derived from the CMU CL system, which was written at
-;;;; Carnegie Mellon University and released into the public domain. The
-;;;; software is in the public domain and is provided with absolutely no
-;;;; warranty. See the COPYING and CREDITS files for more information.
-
-(defpackage :sb-queue
- (:use :cl :sb-thread :sb-sys :sb-ext)
- (:export
- "DEQUEUE"
- "ENQUEUE"
- "LIST-QUEUE-CONTENTS"
- "MAKE-QUEUE"
- "QUEUE"
- "QUEUE-COUNT"
- "QUEUE-EMPTY-P"
- "QUEUE-NAME"
- "QUEUEP"))
-
-(in-package :sb-queue)
-
-(defconstant +dummy+ '.dummy.)
-
-(declaim (inline make-node))
-(defstruct node
- value
- (prev nil :type (or null node))
- (next nil :type (or null node)))
-
-(declaim (inline %make-queue))
-(defstruct (queue (:constructor %make-queue (head tail name))
- (:copier nil)
- (:predicate queuep))
- "Lock-free thread safe queue. ENQUEUE can be used to add objects to the queue,
-and DEQUEUE retrieves items from the queue in FIFO order."
- (head (error "No HEAD.") :type node)
- (tail (error "No TAIL.") :type node)
- (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
-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+))
- (queue (%make-queue dummy dummy name)))
- (flet ((enc-1 (x)
- (enqueue x queue)))
- (declare (dynamic-extent #'enc-1))
- (map nil #'enc-1 initial-contents))
- queue))
-
-(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)))))
-
-(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)))
- (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)))
-
-(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 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))
-
-(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)))
-
-(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+))))
-
-(provide :sb-queue)
+++ /dev/null
-;;;; This software is part of the SBCL system. See the README file for
-;;;; more information.
-;;;;
-;;;; This software is derived from the CMU CL system, which was written at
-;;;; Carnegie Mellon University and released into the public domain. The
-;;;; software is in the public domain and is provided with absolutely no
-;;;; warranty. See the COPYING and CREDITS files for more information.
-
-(defpackage :sb-queue-test
- (:use :cl :sb-thread :sb-queue :sb-rt)
- (:export))
-
-(in-package :sb-queue-test)
-
-(deftest queue.1
- (let ((q (make-queue :name 'test-q :initial-contents '(1 2 3))))
- (enqueue 4 q)
- (values (queue-name q)
- (multiple-value-list (dequeue q))
- (list-queue-contents q)))
- test-q
- (1 t)
- (2 3 4))
-
-(deftest queue.2
- (dequeue (make-queue))
- nil
- nil)
-
-(deftest queue.3
- (dequeue (make-queue :initial-contents '(nil)))
- nil
- t)
-
-(deftest queue.4
- (let ((x (make-instance 'structure-object))
- (y (make-queue)))
- ;; I wonder why I thought this needs testing?
- (values (typep x 'queue)
- (queuep x)
- (typep y 'queue)
- (queuep y)))
- nil nil t t)
-
-(deftest queue.5
- (let ((q (make-queue :initial-contents (vector 1 2 3 4 5))))
- (values (= 5 (queue-count q))
- (enqueue 'foo q)
- (= 6 (queue-count q))
- (dequeue q)
- (= 5 (queue-count q))
- (dequeue q)
- (= 4 (queue-count q))
- (dequeue q)
- (= 3 (queue-count q))
- (dequeue q)
- (= 2 (queue-count q))
- (dequeue q)
- (= 1 (queue-count q))
- (not (queue-empty-p q))
- (dequeue q)
- (= 0 (queue-count q))
- (queue-empty-p q)
- (dequeue q)
- (= 0 (queue-count q))
- (queue-empty-p q)))
- t
- foo
- t
- 1
- t
- 2
- t
- 3
- t
- 4
- t
- 5
- t
- t
- foo
- t
- t
- nil
- t
- t)
-
-#+sb-thread
-(deftest queue.t.1
- (let* ((q (make-queue))
- (w (make-semaphore))
- (r (make-semaphore))
- (n 100000)
- (schedulers (list
- (make-thread (lambda ()
- (signal-semaphore r)
- (wait-on-semaphore w)
- (dotimes (i n)
- (enqueue (cons :a i) q))))
- (make-thread (lambda ()
- (signal-semaphore r)
- (wait-on-semaphore w)
- (dotimes (i n)
- (enqueue (cons :b i) q))))
- (make-thread (lambda ()
- (signal-semaphore r)
- (wait-on-semaphore w)
- (dotimes (i n)
- (enqueue (cons :c i) q))))
- (make-thread (lambda ()
- (signal-semaphore r)
- (wait-on-semaphore w)
- (dotimes (i n)
- (enqueue (cons :d i) q)))))))
- (loop repeat 4 do (wait-on-semaphore r))
- (signal-semaphore w 4)
- (mapc #'join-thread schedulers)
- (let (a b c d)
- (loop
- (multiple-value-bind (item ok) (dequeue q)
- (cond (item
- (assert ok)
- (case (car item)
- (:a (push (cdr item) a))
- (:b (push (cdr item) b))
- (:c (push (cdr item) c))
- (:d (push (cdr item) d))))
- (t
- (assert (not ok))
- (return)))))
- (labels ((check-list (list)
- (when list
- (if (cdr list)
- (when (= (first list) (1- (second list)))
- (check-list (cdr list)))
- (= (first list) (1- n))))))
- (values (check-list (nreverse a))
- (check-list (nreverse b))
- (check-list (nreverse c))
- (check-list (nreverse d))))))
- t
- t
- t
- t)
-
-#+sb-thread
-(deftest queue.t.2
- (let ((q (make-queue))
- (w (make-semaphore))
- (r (make-semaphore)))
- (dotimes (i 1000000)
- (enqueue i q))
- (flet ((dq ()
- (signal-semaphore r)
- (wait-on-semaphore w)
- (let ((last -1))
- (loop
- (multiple-value-bind (x ok) (dequeue q)
- (cond (x
- (if (and (> x last) ok)
- (setf last x)
- (return (list last x ok))))
- (t
- (if (not ok)
- (return t)
- (return (list last x ok))))))))))
- (let ((deschedulers
- (list (make-thread #'dq)
- (make-thread #'dq)
- (make-thread #'dq)
- (make-thread #'dq))))
- (loop repeat 4 do (wait-on-semaphore r))
- (signal-semaphore w 4)
- (mapcar #'join-thread deschedulers))))
- (t t t t))
-
-#+sb-thread
-(deftest queue.t.3
- (let* ((q (make-queue))
- (w (make-semaphore))
- (r (make-semaphore))
- (n 100000)
- (schedulers (list
- (make-thread (lambda ()
- (signal-semaphore r)
- (wait-on-semaphore w)
- (dotimes (i n)
- (enqueue (cons :a i) q))))
- (make-thread (lambda ()
- (signal-semaphore r)
- (wait-on-semaphore w)
- (dotimes (i n)
- (enqueue (cons :b i) q))))
- (make-thread (lambda ()
- (signal-semaphore r)
- (wait-on-semaphore w)
- (dotimes (i n)
- (enqueue (cons :c i) q))))
- (make-thread (lambda ()
- (signal-semaphore r)
- (wait-on-semaphore w)
- (dotimes (i n)
- (enqueue (cons :d i) q)))))))
- (flet ((dq ()
- (let ((a -1)
- (ac 0)
- (b -1)
- (bc 0)
- (c -1)
- (cc 0)
- (d -1)
- (dc 0))
- (signal-semaphore r)
- (wait-on-semaphore w)
- (loop (multiple-value-bind (item ok) (dequeue q)
- (cond (item
- (let ((n (cdr item)))
- (macrolet ((test (name c)
- `(if (< ,name n)
- (progn
- (setf ,name n)
- (incf ,c))
- (return nil))))
- (ecase (car item)
- (:a (test a ac))
- (:b (test b bc))
- (:c (test c cc))
- (:d (test d dc))))))
- (t
- (assert (not ok))
- (unless (or (some #'thread-alive-p schedulers)
- (not (queue-empty-p q)))
- (return (list a ac b bc c cc d dc))))))))))
- (let ((deschedulers (list
- (make-thread #'dq)
- (make-thread #'dq)
- (make-thread #'dq)
- (make-thread #'dq))))
- (loop repeat 8 do (wait-on-semaphore r))
- (signal-semaphore w 8)
- (let ((a -1)
- (ac 0)
- (b -1)
- (bc 0)
- (c -1)
- (cc 0)
- (d -1)
- (dc 0))
- (mapc (lambda (th)
- (let ((results (join-thread th)))
- (when results
- (destructuring-bind (ta tac tb tbc tc tcc td tdc) results
- (setf a (max ta a)
- b (max tb b)
- c (max tc c)
- d (max td d))
- (incf ac tac)
- (incf bc tbc)
- (incf cc tcc)
- (incf dc tdc)))))
- deschedulers)
- (and (= n ac (1+ a))
- (= n bc (1+ b))
- (= n cc (1+ c))
- (= n dc (1+ d)))))))
- t)
projects / sbcl.git / commitdiff