...so that other systems can :depends-on it.
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.
-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
--- /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
+;;; -*- 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)))
+++ /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)
-(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)
(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)
;;; 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"
projects / sbcl.git / commitdiff