;;;; -*- coding: utf-8; fill-column: 78 -*-
changes relative to sbcl-1.0.36:
+ * new contrib: SB-CONCURRENCY is a new contrib; it's supposed to contain
+ additional data structures and tools for concurrent programming; at the
+ moment it contains a lock-free queue, and a lock-free mailbox
+ implementation.
+ * deprecated contrib: the SB-QUEUE contrib was merged into the
+ SB-CONCURRENCY contrib and deprecated.
* new feature: added SB-THREAD:TRY-SEMAPHORE, a non-blocking variant of
SB-THREAD:WAIT-ON-SEMAPHORE.
* new feature: SB-EXT:ATOMIC-DECF has been added as a companion to
--- /dev/null
+SYSTEM=sb-concurrency
+include ../asdf-module.mk
--- /dev/null
+;;;; Lock-free mailbox implementation using SB-QUEUE.
+;;;;
+;;;; Written by Nikodemus Siivola for SBCL.
+;;;; Extended by Tobias C Rittweiler.
+;;;;
+;;;; 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.
+
+(in-package :sb-concurrency)
+
+;; TODO: type and values decls
+
+(defstruct (mailbox (:constructor %make-mailbox (queue semaphore name))
+ (:copier nil)
+ (:predicate mailboxp))
+ "Mailbox aka message queue."
+ (queue (missing-arg) :type queue)
+ (semaphore (missing-arg) :type semaphore)
+ (name nil))
+
+(setf (documentation 'mailboxp 'function)
+ "Returns true if argument is a MAILBOX, NIL otherwise."
+ (documentation 'mailbox-name 'function)
+ "Name of a MAILBOX. SETFable.")
+
+(defun make-mailbox (&key name initial-contents)
+ "Returns a new MAILBOX with messages in INITIAL-CONTENTS enqueued."
+ (flet ((genname (thing name)
+ (format nil "~:[Mailbox ~A~;~A for mailbox ~S~]" name thing name)))
+ (%make-mailbox (make-queue
+ :name (genname "Queue" name)
+ :initial-contents initial-contents)
+ (make-semaphore
+ :name (genname "Semaphore" name)
+ :count (length initial-contents))
+ name)))
+
+(defmethod print-object ((mailbox mailbox) stream)
+ (print-unreadable-object (mailbox stream :type t :identity t)
+ (format stream "~@[~S ~](~D msgs pending)"
+ (mailbox-name mailbox)
+ (mailbox-count mailbox)))
+ mailbox)
+
+(defun mailbox-count (mailbox)
+ "Returns the number of messages currently in the mailbox."
+ (semaphore-count (mailbox-semaphore mailbox)))
+
+(defun mailbox-empty-p (mailbox)
+ "Returns true if MAILBOX is currently empty, NIL otherwise."
+ (zerop (mailbox-count mailbox)))
+
+(defun list-mailbox-messages (mailbox)
+ "Returns a fresh list containing all the messages in the
+mailbox. Does not remove messages from the mailbox."
+ (list-queue-contents (mailbox-queue mailbox)))
+
+(defun send-message (mailbox message)
+ "Adds a MESSAGE to MAILBOX. Message can be any object."
+ (sb-sys:without-interrupts
+ (enqueue message (mailbox-queue mailbox))
+ (signal-semaphore (mailbox-semaphore mailbox))))
+
+;;; TODO: TIMEOUT argument.
+(defun receive-message (mailbox &key)
+ "Removes the oldest message from MAILBOX and returns it as the
+primary value. If MAILBOX is empty waits until a message arrives."
+ (tagbody
+ ;; Disable interrupts for keeping semaphore count in sync with
+ ;; #msgs in the mailbox.
+ (sb-sys:without-interrupts
+ (sb-sys:allow-with-interrupts
+ (wait-on-semaphore (mailbox-semaphore mailbox)))
+ (multiple-value-bind (value ok) (dequeue (mailbox-queue mailbox))
+ (if ok
+ (return-from receive-message value)
+ (go :error))))
+ :error
+ (sb-int:bug "Mailbox ~S empty after WAIT-ON-SEMAPHORE."
+ mailbox)))
+
+(defun receive-message-no-hang (mailbox)
+ "The non-blocking variant of RECEIVE-MESSAGE. Returns two values,
+the message removed from MAILBOX, and a flag specifying whether a
+message could be received."
+ (prog ((semaphore (mailbox-semaphore mailbox))
+ (queue (mailbox-queue mailbox)))
+ ;; Disable interrupts, v.s.
+ (sb-sys:without-interrupts
+ (unless (sb-sys:allow-with-interrupts
+ (sb-thread::try-semaphore semaphore))
+ (return (values nil nil)))
+ (multiple-value-bind (value ok) (dequeue queue)
+ (if ok
+ (return (values value t))
+ (go :error))))
+ :error
+ (sb-int:bug "Mailbox ~S empty after successfull TRY-SEMAPHORE."
+ mailbox)))
+
+(defun receive-pending-messages (mailbox &optional n)
+ "Removes and returns all (or at most N) currently pending messages
+from MAILBOX, or returns NIL if no messages are pending.
+
+Note: Concurrent threads may be snarfing messages during the run of
+this function, so even though X,Y appear right next to each other in
+the result, does not necessarily mean that Y was the message sent
+right after X."
+ (prog* ((msgs '())
+ (sem (mailbox-semaphore mailbox))
+ (queue (mailbox-queue mailbox))
+ (avail (mailbox-count mailbox))
+ (count (if n (min n avail) avail)))
+ (when (zerop count)
+ (go :finish))
+ ;; Disable interrupts, v.s.
+ (sb-sys:without-interrupts
+ (unless (sb-sys:allow-with-interrupts
+ (sb-thread::try-semaphore sem count))
+ (go :slow-path))
+ ;; Safe because QUEUE is private; other threads may be snarfing
+ ;; messages under our feet, though, hence the out of order bit
+ ;; in the docstring. Same for the slow path.
+ (loop
+ (multiple-value-bind (msg ok) (dequeue queue)
+ (unless ok (go :error))
+ (push msg msgs)
+ (when (zerop (decf count))
+ (go :finish)))))
+ ;; This is the slow path as RECEIVE-MESSAGE-NO-HANG will have to
+ ;; lock the semaphore's mutex again and again.
+ :slow-path
+ ;; No need for disabling interrupts because we never leave the
+ ;; mailbox in an inconsistent state here.
+ (loop
+ (multiple-value-bind (msg ok)
+ (receive-message-no-hang mailbox)
+ (unless ok (go :finish))
+ (push msg msgs)
+ (when (zerop (decf count))
+ (go :finish))))
+ :finish
+ (return (nreverse msgs))
+ :error
+ (sb-int:bug "Mailbox ~S empty after successfull TRY-SEMAPHORE."
+ mailbox)))
--- /dev/null
+(defpackage :sb-concurrency
+ (:use :cl :sb-thread)
+ (:export
+ ;; MAILBOX
+ "LIST-MAILBOX-MESSAGES"
+ "MAILBOX"
+ "MAILBOX-COUNT"
+ "MAILBOX-EMPTY-P"
+ "MAILBOX-NAME"
+ "MAILBOXP"
+ "MAKE-MAILBOX"
+ "RECEIVE-MESSAGE"
+ "RECEIVE-MESSAGE-NO-HANG"
+ "RECEIVE-PENDING-MESSAGES"
+ "SEND-MESSAGE"
+
+ ;; QUEUE
+ "DEQUEUE"
+ "ENQUEUE"
+ "LIST-QUEUE-CONTENTS"
+ "MAKE-QUEUE"
+ "QUEUE"
+ "QUEUE-COUNT"
+ "QUEUE-EMPTY-P"
+ "QUEUE-NAME"
+ "QUEUEP"
+ ))
\ No newline at end of file
--- /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.
+
+(in-package :sb-concurrency)
+
+(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."
+ (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+))))
--- /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.
+
+(in-package :cl-user)
+
+(asdf:defsystem :sb-concurrency
+ :components ((:file "package")
+ (:file "queue" :depends-on ("package"))
+ (:file "mailbox" :depends-on ("package" "queue"))))
+
+(asdf:defsystem :sb-concurrency-tests
+ :depends-on (:sb-concurrency :sb-rt)
+ :components
+ ((:module tests
+ :components
+ ((:file "package")
+ (:file "test-utils" :depends-on ("package"))
+ (:file "test-queue" :depends-on ("package" "test-utils"))
+ (:file "test-mailbox" :depends-on ("package" "test-utils"))))))
+
+(defmethod asdf:perform :after ((o asdf:load-op)
+ (c (eql (asdf:find-system :sb-concurrency))))
+ (provide 'sb-concurrency))
+
+(defmethod asdf:perform ((o asdf:test-op)
+ (c (eql (asdf:find-system :sb-concurrency))))
+ (asdf:oos 'asdf:load-op :sb-concurrency-tests)
+ (asdf:oos 'asdf:test-op :sb-concurrency-tests))
+
+(defmethod asdf:perform ((o asdf:test-op)
+ (c (eql (asdf:find-system :sb-concurrency-tests))))
+ (or (funcall (intern "DO-TESTS" (find-package "SB-RT")))
+ (error "~S failed" 'asdf:test-op)))
--- /dev/null
+@node sb-concurrency
+@section sb-concurrency
+@cindex Concurrency
+@cindex Sb-concurrency
+
+Additional data structures, synchronization primitives and tools for
+concurrent programming. Similiar to Java's @code{java.util.concurrent}
+package.
+
+@page
+@anchor{Section sb-concurrency:queue}
+@subsection Queue
+@cindex Queue, lock-free
+
+@code{sb-concurrency:queue} is a lock-free, thread-safe FIFO queue
+datatype.
+@*@*
+The implementation is based on @cite{An Optimistic Approach to
+Lock-Free FIFO Queues} by Edya Ladan-Mozes and Nir Shavit.
+@*@*
+Before SBCL 1.0.38, this implementation resided in its own contrib
+(@pxref{sb-queue}) which is still provided for backwards-compatibility
+but which has since been deprecated.
+
+@sp 1
+@unnumberedsubsubsec Synopsis:
+
+@code{enqueue} can be used to add objects to a queue, and
+@code{dequeue} retrieves items from a queue in FIFO order.
+
+@sp 1
+@unnumberedsubsubsec Dictionary:
+
+@include struct-sb-concurrency-queue.texinfo
+
+@include fun-sb-concurrency-dequeue.texinfo
+@include fun-sb-concurrency-enqueue.texinfo
+@include fun-sb-concurrency-list-queue-contents.texinfo
+@include fun-sb-concurrency-make-queue.texinfo
+@include fun-sb-concurrency-queue-count.texinfo
+@include fun-sb-concurrency-queue-empty-p.texinfo
+@include fun-sb-concurrency-queue-name.texinfo
+@include fun-sb-concurrency-queuep.texinfo
+
+@page
+@subsection Mailbox (lock-free)
+@cindex Mailbox, lock-free
+
+@code{sb-concurrency:mailbox} is a lock-free message queue where one
+or multiple ends can send messages to one or multiple receivers. The
+difference to @ref{Section sb-concurrency:queue} is that the receiving
+end may block until a message arrives.
+@*@*
+The implementation is based on the Queue implementation above
+(@pxref{Structure sb-concurrency:queue}.)
+
+@sp 1
+@unnumberedsubsubsec Synopsis:
+@code{send-message} can be used to send a message to a mailbox, and
+@code{receive-message} retrieves a message from a mailbox, or blocks
+until a new message arrives. @code{receive-message-no-hang} is the
+non-blocking variant.
+@*@*
+Messages can be any object.
+
+@sp 1
+@unnumberedsubsubsec Dictionary:
+
+@include struct-sb-concurrency-mailbox.texinfo
+
+@include fun-sb-concurrency-list-mailbox-messages.texinfo
+@include fun-sb-concurrency-mailbox-count.texinfo
+@include fun-sb-concurrency-mailbox-empty-p.texinfo
+@include fun-sb-concurrency-mailbox-name.texinfo
+@include fun-sb-concurrency-mailboxp.texinfo
+@include fun-sb-concurrency-make-mailbox.texinfo
+@include fun-sb-concurrency-receive-message.texinfo
+@include fun-sb-concurrency-receive-message-no-hang.texinfo
+@include fun-sb-concurrency-receive-pending-messages.texinfo
+@include fun-sb-concurrency-send-message.texinfo
--- /dev/null
+
+(in-package :cl-user)
+
+(defpackage :sb-concurrency-test
+ (:use :cl :sb-thread :sb-concurrency :sb-rt))
\ No newline at end of file
--- /dev/null
+;;;; 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.
+
+(in-package :sb-concurrency-test)
+
+(deftest mailbox-trivia.1
+ (values (mailboxp (make-mailbox))
+ (mailboxp 42))
+ t
+ nil)
+
+(deftest mailbox-trivia.2
+ (let ((mbox1 (make-mailbox :name "foof"))
+ (mbox2 (make-mailbox)))
+ (values (mailbox-name mbox1)
+ (mailbox-name mbox2)))
+ "foof"
+ nil)
+
+(deftest mailbox-trivia.3
+ (flet ((test (initial-contents)
+ (let ((mbox (make-mailbox :initial-contents initial-contents)))
+ (list (mailbox-count mbox)
+ (mailbox-empty-p mbox)
+ (list-mailbox-messages mbox)
+ (eq (list-mailbox-messages mbox) initial-contents)))))
+ (values (test '(1 2 3))
+ (test #(1 2 3))
+ (test "123")
+ (test nil)))
+ (3 nil (1 2 3) nil)
+ (3 nil (1 2 3) nil)
+ (3 nil (#\1 #\2 #\3) nil)
+ (0 t nil t))
+
+#+sb-thread
+(progn
+
+;; Dummy struct for ATOMIC-INCF to work.
+(defstruct counter
+ (ref 0 :type sb-vm:word))
+
+(defun test-mailbox-producers-consumers
+ (&key n-senders n-receivers n-messages mailbox interruptor)
+ (let* ((cnt (make-counter))
+ (mbox (or mailbox (make-mailbox)))
+ (senders
+ (make-threads n-senders "SENDER"
+ #'(lambda ()
+ (dotimes (i n-messages)
+ (send-message mbox i)
+ (sleep (random 0.001))))))
+ (receivers
+ ;; We have three groups of receivers, one using
+ ;; RECEIVE-MESSAGE, one RECEIVE-MESSAGE-NO-HANG, and another
+ ;; one RECEIVE-PENDING-MESSAGES.
+ (let* ((aux (floor n-receivers 2))
+ (n-recv-msg (- n-receivers aux))
+ (n-recv-pend-msgs (floor aux 3))
+ (n-recv-msg-n-h (- aux n-recv-pend-msgs)))
+ (append
+ (make-threads n-recv-msg "RECV-MSG"
+ #'(lambda ()
+ (sleep (random 0.001))
+ (handler-case
+ (loop
+ (sb-sys:with-deadline (:seconds 1.0)
+ (let ((msg (receive-message mbox)))
+ (sb-ext:atomic-incf (counter-ref cnt))
+ (unless (< -1 msg n-messages)
+ (hang)))))
+ (sb-ext:timeout ()))))
+ (make-threads n-recv-pend-msgs "RECV-PEND-MSGS"
+ #'(lambda ()
+ (sleep (random 0.001))
+ (dotimes (i 10)
+ (thread-yield)
+ (let ((msgs (receive-pending-messages mbox (random 5))))
+ (mapc #'(lambda (msg)
+ (sb-ext:atomic-incf (counter-ref cnt))
+ (unless (< -1 msg n-messages)
+ (hang)))
+ msgs)))))
+ (make-threads n-recv-msg-n-h "RECV-MSG-NO-HANG"
+ #'(lambda ()
+ (sleep (random 0.001))
+ (dotimes (i 30)
+ (thread-yield)
+ (multiple-value-bind (msg ok)
+ (receive-message-no-hang mbox)
+ (when ok
+ (sb-ext:atomic-incf (counter-ref cnt))
+ (unless (< -1 msg n-messages)
+ (hang))))))))))
+ (threads (append receivers senders)))
+ (when interruptor (funcall interruptor threads))
+ (mapc #'timed-join-thread threads)
+ (values mbox (counter-ref cnt) (* n-senders n-messages))))
+
+(deftest mailbox.single-producer-single-consumer
+ (multiple-value-bind (mbox received total)
+ (test-mailbox-producers-consumers :n-senders 1
+ :n-receivers 1
+ :n-messages 10000)
+ (values
+ (= received total)
+ (mailbox-count mbox)
+ (list-mailbox-messages mbox)))
+ t
+ 0
+ nil)
+
+(deftest mailbox.single-producer-multiple-consumers
+ (multiple-value-bind (mbox received total)
+ (test-mailbox-producers-consumers :n-senders 1
+ :n-receivers 100
+ :n-messages 10000)
+ (values
+ (= received total)
+ (mailbox-count mbox)
+ (list-mailbox-messages mbox)))
+ t
+ 0
+ nil)
+
+(deftest mailbox.multiple-producers-single-consumer
+ (multiple-value-bind (mbox received total)
+ (test-mailbox-producers-consumers :n-senders 100
+ :n-receivers 10
+ :n-messages 1000)
+ (values
+ (= received total)
+ (mailbox-count mbox)
+ (list-mailbox-messages mbox)))
+ t
+ 0
+ nil)
+
+(deftest mailbox.multiple-producers-multiple-consumers
+ (multiple-value-bind (mbox received total)
+ (test-mailbox-producers-consumers :n-senders 100
+ :n-receivers 100
+ :n-messages 1000)
+ (values
+ (= received total)
+ (mailbox-count mbox)
+ (list-mailbox-messages mbox)))
+ t
+ 0
+ nil)
+
+(deftest mailbox.interrupts-safety.1
+ (multiple-value-bind (mbox received total)
+ (test-mailbox-producers-consumers
+ :n-senders 100
+ :n-receivers 100
+ :n-messages 1000
+ :interruptor #'(lambda (threads)
+ (let ((n (length threads)))
+ ;; 99 so even in the unlikely case that only
+ ;; receivers (or only senders) are shot
+ ;; dead, there's still one that survives to
+ ;; properly end the test.
+ (loop repeat 99 do
+ (kill-thread (nth (random n) threads))))))
+ (values
+ ;; We may have killed a receiver before it got to incrementing
+ ;; the counter.
+ (<= received total)
+ (mailbox-count mbox)
+ (list-mailbox-messages mbox)))
+ t
+ 0
+ nil)
+
+) ; #+sb-thread (progn ...
\ No newline at end of file
--- /dev/null
+;;;; 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.
+
+(in-package :sb-concurrency-test)
+
+(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))
+
+(deftest queue.2
+ (dequeue (make-queue))
+ nil
+ nil)
+
+(deftest queue.3
+ (dequeue (make-queue :initial-contents '(nil)))
+ nil
+ t)
+
+(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)
+
+(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
+(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
+(deftest queue.t.2
+ (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 #'join-thread deschedulers))))
+ (t t t t))
+
+#+sb-thread
+(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)
--- /dev/null
+(in-package :sb-concurrency-test)
+
+#+sb-thread
+(progn
+
+(defparameter +timeout+ 60.0)
+
+(defun make-threads (n name fn)
+ (loop for i from 1 to n
+ collect (make-thread fn :name (format nil "~A-~D" name i))))
+
+(defun timed-join-thread (thread &optional (timeout +timeout+))
+ (sb-sys:with-deadline (:seconds timeout)
+ (join-thread thread :default :aborted)))
+
+(defun hang ()
+ (join-thread *current-thread*))
+
+(defun kill-thread (thread)
+ (when (thread-alive-p thread)
+ (ignore-errors
+ (terminate-thread thread))))
+
+) ;; #+sb-thread (progn ...
\ No newline at end of file
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
-(defpackage :sb-queue-system
- (:use :asdf :cl))
+(in-package :cl-user)
-(in-package :sb-queue-system)
+(asdf:defsystem :sb-queue
+ :depends-on (:sb-concurrency)
+ :components ((:file "package")))
-(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))))
+(defmethod asdf:perform :after ((o asdf:load-op)
+ (c (eql (asdf: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)))
+(defmethod asdf:perform ((o asdf:test-op)
+ (c (eql (asdf:find-system :sb-queue))))
+ :pass)
\ No newline at end of file
@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
+Since SBCL 1.0.38, the @code{sb-queue} module has been merged into the
+@code{sb-concurrency} module (@pxref{sb-concurrency}.)
CONTRIBDIR="../../contrib/"
I_FLAGS=-I $(DOCSTRINGDIR) -I $(CONTRIBDIR)
# List of contrib modules that docstring docs will be created for.
-MODULES=':sb-md5 :sb-queue :sb-rotate-byte :sb-grovel :sb-sprof :sb-bsd-sockets :sb-cover :sb-posix'
+MODULES=':sb-md5 :sb-queue :sb-concurrency :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-QUEUE :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 :SB-CONCURRENCY"
# SBCL_SYSTEM is an optional argument to this make program. If this
# variable is set, its contents are used as the command line for
# are in $(CONTRIBDIR).
CONTRIB_FASLS=$(shell find $(shell echo $(MODULES) | sed "s|:|$(CONTRIBDIR)|g") -name '*.fasl')
docstrings: $(CONTRIB_FASLS) tempfiles-stamp
- for module in $(shell echo $(MODULES)); do test -e $(CONTRIBDIR)/$${module#:}/test-passed || { echo "The documented contrib $$module seems to have failed its tests." && exit 1; }; done
- DOCSTRINGDIR=$(DOCSTRINGDIR) PACKAGES=$(PACKAGES) MODULES=$(MODULES) sh make-tempfiles.sh "$(SBCL_SYSTEM)" && touch $(DOCSTRINGDIR)
+ for module in $(shell echo $(MODULES)); do \
+ test -e $(CONTRIBDIR)/$${module#:}/test-passed \
+ || { echo "The documented contrib $$module seems \
+ to have failed its tests." && exit 1; } \
+ done
+ DOCSTRINGDIR=$(DOCSTRINGDIR) \
+ PACKAGES=$(PACKAGES) \
+ MODULES=$(MODULES) \
+ sh make-tempfiles.sh "$(SBCL_SYSTEM)" && touch $(DOCSTRINGDIR)
tempfiles-stamp:
touch tempfiles-stamp
SBCL comes with a number of modules that are not part of the core
system. These are loaded via @code{(require :@var{modulename})}
(@pxref{Customization Hooks for Users}). This section contains
-documentation (or pointers to documentation) for some of the contributed
-modules.
+documentation (or pointers to documentation) for some of the
+contributed modules.
@menu
* sb-aclrepl::
+* sb-concurrency::
+* sb-cover::
* sb-grovel::
-* sb-posix::
* sb-md5::
+* sb-posix::
* sb-queue::
* sb-rotate-byte::
-* sb-cover::
@end menu
@page
@include sb-aclrepl/sb-aclrepl.texinfo
@page
-@include sb-grovel/sb-grovel.texinfo
+@include sb-concurrency/sb-concurrency.texinfo
@page
-@include sb-posix/sb-posix.texinfo
+@include sb-cover/sb-cover.texinfo
+
+@page
+@include sb-grovel/sb-grovel.texinfo
@page
@include sb-md5/sb-md5.texinfo
@page
+@include sb-posix/sb-posix.texinfo
+
+@page
@include sb-queue/sb-queue.texinfo
@page
@include sb-rotate-byte/sb-rotate-byte.texinfo
-@page
-@include sb-cover/sb-cover.texinfo
+
;;; 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.37.17"
+"1.0.37.18"
projects / sbcl.git / commitdiff