* Lockless thread-safe FIFO queue.
* minor incompatible change: SB-THREAD:JOIN-THREAD-ERROR-THREAD and
SB-THREAD:INTERRUPT-THREAD-ERROR-THREAD have been deprecated in favor
of SB-THREAD:THREAD-ERROR-THREAD.
+ * new contrib module: SB-QUEUE provides thread-safe lockless FIFO queues.
* new feature: docstrings for local and anonymous functions are no longer
discarded. (thanks to Leslie Polzer)
* new feature: SB-THREAD:SYMBOL-VALUE-IN-THREAD provides access to symbol
--- /dev/null
+MODULE=sb-queue
+include ../vanilla-module.mk
+
+test::
+ echo "TEST sb-queue"
+ $(SBCL) --disable-debugger --load test-queue.lisp
--- /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
+@node sb-queue
+@section sb-queue
+@cindex Queue, FIFO
+
+The @code{sb-queue} module, loadable by
+@lisp
+(require :sb-queue)
+@end lisp
+provides a thread-safe lockless FIFO queues.
+
+@include struct-sb-queue-queue.texinfo
+
+@include fun-sb-queue-dequeue.texinfo
+@include fun-sb-queue-enqueue.texinfo
+@include fun-sb-queue-list-queue-contents.texinfo
+@include fun-sb-queue-make-queue.texinfo
+@include fun-sb-queue-queue-count.texinfo
+@include fun-sb-queue-queue-empty-p.texinfo
+@include fun-sb-queue-queue-name.texinfo
+@include fun-sb-queue-queuep.texinfo
--- /dev/null
+(require :sb-queue)
+
+(defpackage :sb-queue-test
+ (:use :cl :sb-thread :sb-queue)
+ (:export))
+
+(in-package :sb-queue-test)
+
+(let ((q (make-queue :name 'test-q :initial-contents '(1 2 3))))
+ (enqueue 4 q)
+ (assert (eq 'test-q (queue-name q)))
+ (multiple-value-bind (v ok) (dequeue q)
+ (assert (eql 1 v))
+ (assert (eq t ok)))
+ (assert (equal (list-queue-contents q) (list 2 3 4))))
+
+(assert (equal (list nil nil) (multiple-value-list (dequeue (make-queue)))))
+
+(assert (equal (list nil t) (multiple-value-list (dequeue (make-queue :initial-contents '(nil))))))
+
+(let ((x (make-instance 'structure-object))
+ (y (make-queue)))
+ (assert (not (typep x 'queue)))
+ (assert (not (queuep x)))
+ (assert (typep y 'queue))
+ (assert (queuep y)))
+
+(let ((q (make-queue :initial-contents (vector 1 2 3 4 5))))
+ (assert (= 5 (queue-count q)))
+ (enqueue 'foo q)
+ (assert (= 6 (queue-count q)))
+ (dequeue q)
+ (assert (= 5 (queue-count q)))
+ (dequeue q)
+ (assert (= 4 (queue-count q)))
+ (dequeue q)
+ (assert (= 3 (queue-count q)))
+ (dequeue q)
+ (assert (= 2 (queue-count q)))
+ (dequeue q)
+ (assert (= 1 (queue-count q)))
+ (assert (not (queue-empty-p q)))
+ (dequeue q)
+ (assert (= 0 (queue-count q)))
+ (assert (queue-empty-p q))
+ (dequeue q)
+ (assert (= 0 (queue-count q)))
+ (assert (queue-empty-p q)))
+
+#+sb-thread
+(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))))))
+ (assert (eq t (check-list (nreverse a))))
+ (assert (eq t (check-list (nreverse b))))
+ (assert (eq t (check-list (nreverse c))))
+ (assert (eq t (check-list (nreverse d)))))))
+
+#+sb-thread
+(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 (lambda (th)
+ (assert (eq t (join-thread th))))
+ deschedulers))))
+
+#+sb-thread
+(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)
+ (assert (and (= n ac (1+ a))
+ (= n bc (1+ b))
+ (= n cc (1+ c))
+ (= n dc (1+ d))))))))
+
+;;;; Unix success convention for exit codes
+(sb-ext:quit :unix-status 0)
CONTRIBDIR="../../contrib/"
I_FLAGS=-I $(DOCSTRINGDIR) -I $(CONTRIBDIR)
# List of contrib modules that docstring docs will be created for.
-MODULES=':sb-md5 :sb-rotate-byte :sb-grovel :sb-sprof :sb-bsd-sockets :sb-cover :sb-posix'
+MODULES=':sb-md5 :sb-queue :sb-rotate-byte :sb-grovel :sb-sprof :sb-bsd-sockets :sb-cover :sb-posix'
# List of package names that docstring docs will be created for.
-PACKAGES=":COMMON-LISP :SB-ALIEN :SB-DEBUG :SB-EXT :SB-GRAY :SB-MOP :SB-PROFILE :SB-THREAD :SB-MD5 :SB-ROTATE-BYTE :SB-SPROF :SB-BSD-SOCKETS :SB-COVER :SB-POSIX"
+PACKAGES=":COMMON-LISP :SB-ALIEN :SB-DEBUG :SB-EXT :SB-GRAY :SB-MOP :SB-PROFILE :SB-THREAD :SB-MD5 :SB-QUEUE :SB-ROTATE-BYTE :SB-SPROF :SB-BSD-SOCKETS :SB-COVER :SB-POSIX"
# SBCL_SYSTEM is an optional argument to this make program. If this
# variable is set, its contents are used as the command line for
* sb-grovel::
* sb-posix::
* sb-md5::
+* sb-queue::
* sb-rotate-byte::
* sb-cover::
@end menu
@include sb-md5/sb-md5.texinfo
@page
+@include sb-queue/sb-queue.texinfo
+
+@page
@include sb-rotate-byte/sb-rotate-byte.texinfo
@page
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.29.30"
+"1.0.29.31"
projects / sbcl.git / commitdiff