From e4c97b48dc9bb4d08df159e21871b624ff283ef5 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 18 Dec 2009 13:21:44 +0000 Subject: [PATCH] 1.0.33.25: switch SB-QUEUE into using ASDF ...so that other systems can :depends-on it. --- NEWS | 1 + contrib/sb-queue/Makefile | 8 +- contrib/sb-queue/queue.lisp | 162 +++++++++++++++ contrib/sb-queue/sb-queue.asd | 33 +++ contrib/sb-queue/sb-queue.lisp | 162 --------------- contrib/sb-queue/test-queue.lisp | 408 +++++++++++++++++++++----------------- version.lisp-expr | 2 +- 7 files changed, 424 insertions(+), 352 deletions(-) create mode 100644 contrib/sb-queue/queue.lisp create mode 100644 contrib/sb-queue/sb-queue.asd delete mode 100644 contrib/sb-queue/sb-queue.lisp diff --git a/NEWS b/NEWS index cf7bef2..5a2225a 100644 --- a/NEWS +++ b/NEWS @@ -6,6 +6,7 @@ changes relative to sbcl-1.0.33: are now caught and reported just like errors during macroexpansion. * enhancement: SB-POSIX now provides access to tcdrain(), tcflow(), tcflush(), tcgetsid(), and tcsendbreak(). (thanks to Jerry James) + * enhancement: ASDF systems can now depends on SB-QUEUE. * fixes and improvements related to Unicode and external formats: ** bug fix: error handling and restart usage in the ucs-2 external format has been improved. diff --git a/contrib/sb-queue/Makefile b/contrib/sb-queue/Makefile index 9e08a10..be5107b 100644 --- a/contrib/sb-queue/Makefile +++ b/contrib/sb-queue/Makefile @@ -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 diff --git a/contrib/sb-queue/queue.lisp b/contrib/sb-queue/queue.lisp new file mode 100644 index 0000000..dfe96b3 --- /dev/null +++ b/contrib/sb-queue/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.asd b/contrib/sb-queue/sb-queue.asd new file mode 100644 index 0000000..78ce92d --- /dev/null +++ b/contrib/sb-queue/sb-queue.asd @@ -0,0 +1,33 @@ +;;; -*- 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))) diff --git a/contrib/sb-queue/sb-queue.lisp b/contrib/sb-queue/sb-queue.lisp deleted file mode 100644 index dfe96b3..0000000 --- a/contrib/sb-queue/sb-queue.lisp +++ /dev/null @@ -1,162 +0,0 @@ -;;;; 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/test-queue.lisp b/contrib/sb-queue/test-queue.lisp index 3a0b2a5..48b7b62 100644 --- a/contrib/sb-queue/test-queue.lisp +++ b/contrib/sb-queue/test-queue.lisp @@ -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) diff --git a/version.lisp-expr b/version.lisp-expr index 5780826..371a3d5 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.33.24" +"1.0.33.25" -- 1.7.10.4