From: Nikodemus S. <de...@us...> - 2009-12-18 13:21:57
|
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 --- |