From 3cd07d95709e7059ed76076e9978ac21bd5b3629 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 22 Jun 2009 11:53:51 +0000 Subject: [PATCH] 1.0.29.31: new contrib: SB-QUEUE * Lockless thread-safe FIFO queue. --- NEWS | 1 + contrib/sb-queue/Makefile | 6 + contrib/sb-queue/sb-queue.lisp | 162 ++++++++++++++++++++++++++ contrib/sb-queue/sb-queue.texinfo | 20 ++++ contrib/sb-queue/test-queue.lisp | 224 ++++++++++++++++++++++++++++++++++++ doc/manual/Makefile | 4 +- doc/manual/contrib-modules.texinfo | 4 + version.lisp-expr | 2 +- 8 files changed, 420 insertions(+), 3 deletions(-) create mode 100644 contrib/sb-queue/Makefile create mode 100644 contrib/sb-queue/sb-queue.lisp create mode 100644 contrib/sb-queue/sb-queue.texinfo create mode 100644 contrib/sb-queue/test-queue.lisp diff --git a/NEWS b/NEWS index 4798045..b7c8756 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,7 @@ * 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 diff --git a/contrib/sb-queue/Makefile b/contrib/sb-queue/Makefile new file mode 100644 index 0000000..9e08a10 --- /dev/null +++ b/contrib/sb-queue/Makefile @@ -0,0 +1,6 @@ +MODULE=sb-queue +include ../vanilla-module.mk + +test:: + echo "TEST sb-queue" + $(SBCL) --disable-debugger --load test-queue.lisp diff --git a/contrib/sb-queue/sb-queue.lisp b/contrib/sb-queue/sb-queue.lisp new file mode 100644 index 0000000..dfe96b3 --- /dev/null +++ b/contrib/sb-queue/sb-queue.lisp @@ -0,0 +1,162 @@ +;;;; 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) diff --git a/contrib/sb-queue/sb-queue.texinfo b/contrib/sb-queue/sb-queue.texinfo new file mode 100644 index 0000000..84bd02a --- /dev/null +++ b/contrib/sb-queue/sb-queue.texinfo @@ -0,0 +1,20 @@ +@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 diff --git a/contrib/sb-queue/test-queue.lisp b/contrib/sb-queue/test-queue.lisp new file mode 100644 index 0000000..519d032 --- /dev/null +++ b/contrib/sb-queue/test-queue.lisp @@ -0,0 +1,224 @@ +(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) diff --git a/doc/manual/Makefile b/doc/manual/Makefile index 4d07799..43a6257 100644 --- a/doc/manual/Makefile +++ b/doc/manual/Makefile @@ -14,9 +14,9 @@ DOCSTRINGDIR="docstrings/" 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 diff --git a/doc/manual/contrib-modules.texinfo b/doc/manual/contrib-modules.texinfo index 06edcc6..9ea5c67 100644 --- a/doc/manual/contrib-modules.texinfo +++ b/doc/manual/contrib-modules.texinfo @@ -13,6 +13,7 @@ modules. * sb-grovel:: * sb-posix:: * sb-md5:: +* sb-queue:: * sb-rotate-byte:: * sb-cover:: @end menu @@ -30,6 +31,9 @@ modules. @include sb-md5/sb-md5.texinfo @page +@include sb-queue/sb-queue.texinfo + +@page @include sb-rotate-byte/sb-rotate-byte.texinfo @page diff --git a/version.lisp-expr b/version.lisp-expr index 19133e5..8428885 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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" -- 1.7.10.4