[prev in list] [next in list] [prev in thread] [next in thread]
List: sbcl-commits
Subject: [Sbcl-commits] CVS: sbcl/contrib/sb-queue queue.lisp, NONE,
From: "Nikodemus Siivola" <demoss () users ! sourceforge ! net>
Date: 2009-12-18 13:21:49
Message-ID: E1NLcmD-0008Jm-6B () sfp-cvsdas-3 ! v30 ! ch3 ! sourceforge ! com
[Download RAW message or body]
Update of /cvsroot/sbcl/sbcl/contrib/sb-queue
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv31958/contrib/sb-queue
Modified Files:
Makefile test-queue.lisp
Added Files:
queue.lisp sb-queue.asd
Removed Files:
sb-queue.lisp
Log Message:
1.0.33.25: switch SB-QUEUE into using ASDF
...so that other systems can :depends-on it.
--- NEW FILE: queue.lisp ---
;;;; 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)
--- NEW FILE: sb-queue.asd ---
;;; -*- Lisp -*-
;;;; 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-system
(:use :asdf :cl))
(in-package :sb-queue-system)
(defsystem :sb-queue
:components ((:file "queue")))
(defsystem :sb-queue-tests
:depends-on (:sb-queue :sb-rt)
:components ((:file "test-queue")))
(defmethod perform :after ((o load-op) (c (eql (find-system :sb-queue))))
(provide 'sb-queue))
(defmethod perform ((o test-op) (c (eql (find-system :sb-queue))))
(operate 'load-op :sb-queue-tests)
(operate 'test-op :sb-queue-tests))
(defmethod perform ((op test-op) (com (eql (find-system :sb-queue-tests))))
(or (funcall (intern "DO-TESTS" (find-package "SB-RT")))
(error "~S failed" 'test-op)))
Index: Makefile
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-queue/Makefile,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- Makefile 22 Jun 2009 11:53:51 -0000 1.1
+++ Makefile 18 Dec 2009 13:21:46 -0000 1.2
@@ -1,6 +1,2 @@
-MODULE=sb-queue
-include ../vanilla-module.mk
-
-test::
- echo "TEST sb-queue"
- $(SBCL) --disable-debugger --load test-queue.lisp
+SYSTEM=sb-queue
+include ../asdf-module.mk
Index: test-queue.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-queue/test-queue.lisp,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- test-queue.lisp 25 Jun 2009 14:55:41 -0000 1.2
+++ test-queue.lisp 18 Dec 2009 13:21:47 -0000 1.3
@@ -1,107 +1,151 @@
-(require :sb-queue)
+;;;; 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)
+ (:use :cl :sb-thread :sb-queue :sb-rt)
(: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))))
+(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))
-(assert (equal (list nil nil) (multiple-value-list (dequeue (make-queue)))))
+(deftest queue.2
+ (dequeue (make-queue))
+ nil
+ nil)
-(assert (equal (list nil t) (multiple-value-list (dequeue (make-queue :initial-contents '(nil))))))
+(deftest queue.3
+ (dequeue (make-queue :initial-contents '(nil)))
+ nil
+ t)
-(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)))
+(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)
-(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)))
+(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
-(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)))))))
+(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
-(let ((q (make-queue))
+(deftest queue.t.2
+ (let ((q (make-queue))
(w (make-semaphore))
(r (make-semaphore)))
(dotimes (i 1000000)
@@ -127,98 +171,96 @@
(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))))
+ (mapcar #'join-thread deschedulers))))
+ (t t t t))
#+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)
+(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)
--- sb-queue.lisp DELETED ---
------------------------------------------------------------------------------
This SF.Net email is sponsored by the Verizon Developer Community
Take advantage of Verizon's best-in-class app development support
A streamlined, 14 day to market process makes app distribution fast and easy
Join now and get one step closer to millions of Verizon customers
http://p.sf.net/sfu/verizon-dev2dev
_______________________________________________
Sbcl-commits mailing list
Sbcl-commits@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/sbcl-commits
[prev in list] [next in list] [prev in thread] [next in thread]
Configure |
About |
News |
Add a list |
Sponsored by KoreLogic