From: Tobias C. Rittweiler <trittweiler@users.sourceforge.net>
Date: Tue, 30 Mar 2010 10:46:43 +0000 (+0000)
Subject: 1.0.37.18: New contrib SB-CONCURRENCY.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=ea0735f0b8bab352d6c9797abec19e8c63563cf6;p=sbcl.git

1.0.37.18: New contrib SB-CONCURRENCY.

sb-concurrency related changes:

  * create contrib/sb-concurrency/

  * add the implementation of lock-free Queues from sb-queue.

  * add a new implementation of Mailboxes on top of the Queues.

sb-queue related changes:

  * merged into sb-concurrency

  * deprecated now, but the system / package is still retained for
    backwards compatibility; the package simply reexports from
    sb-concurrency.

doc changes:

  * add section for sb-concurrency to manual
---

diff --git a/NEWS b/NEWS
index e8f657f..762cfe0 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,11 @@
 ;;;; -*- 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
diff --git a/contrib/sb-concurrency/Makefile b/contrib/sb-concurrency/Makefile
new file mode 100644
index 0000000..93922d1
--- /dev/null
+++ b/contrib/sb-concurrency/Makefile
@@ -0,0 +1,2 @@
+SYSTEM=sb-concurrency
+include ../asdf-module.mk
diff --git a/contrib/sb-concurrency/mailbox.lisp b/contrib/sb-concurrency/mailbox.lisp
new file mode 100644
index 0000000..ba4f651
--- /dev/null
+++ b/contrib/sb-concurrency/mailbox.lisp
@@ -0,0 +1,151 @@
+;;;; 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)))
diff --git a/contrib/sb-concurrency/package.lisp b/contrib/sb-concurrency/package.lisp
new file mode 100644
index 0000000..a9124b6
--- /dev/null
+++ b/contrib/sb-concurrency/package.lisp
@@ -0,0 +1,27 @@
+(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
diff --git a/contrib/sb-concurrency/queue.lisp b/contrib/sb-concurrency/queue.lisp
new file mode 100644
index 0000000..fec6d0f
--- /dev/null
+++ b/contrib/sb-concurrency/queue.lisp
@@ -0,0 +1,146 @@
+;;;; 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+))))
diff --git a/contrib/sb-concurrency/sb-concurrency.asd b/contrib/sb-concurrency/sb-concurrency.asd
new file mode 100644
index 0000000..4246d5b
--- /dev/null
+++ b/contrib/sb-concurrency/sb-concurrency.asd
@@ -0,0 +1,41 @@
+;;;; -*-  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)))
diff --git a/contrib/sb-concurrency/sb-concurrency.texinfo b/contrib/sb-concurrency/sb-concurrency.texinfo
new file mode 100644
index 0000000..f81223c
--- /dev/null
+++ b/contrib/sb-concurrency/sb-concurrency.texinfo
@@ -0,0 +1,80 @@
+@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
diff --git a/contrib/sb-concurrency/tests/package.lisp b/contrib/sb-concurrency/tests/package.lisp
new file mode 100644
index 0000000..bffd113
--- /dev/null
+++ b/contrib/sb-concurrency/tests/package.lisp
@@ -0,0 +1,5 @@
+
+(in-package :cl-user)
+
+(defpackage :sb-concurrency-test
+  (:use :cl :sb-thread :sb-concurrency :sb-rt))
\ No newline at end of file
diff --git a/contrib/sb-concurrency/tests/test-mailbox.lisp b/contrib/sb-concurrency/tests/test-mailbox.lisp
new file mode 100644
index 0000000..87d76d8
--- /dev/null
+++ b/contrib/sb-concurrency/tests/test-mailbox.lisp
@@ -0,0 +1,181 @@
+;;;; 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
diff --git a/contrib/sb-concurrency/tests/test-queue.lisp b/contrib/sb-concurrency/tests/test-queue.lisp
new file mode 100644
index 0000000..98dc395
--- /dev/null
+++ b/contrib/sb-concurrency/tests/test-queue.lisp
@@ -0,0 +1,262 @@
+;;;; 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)
diff --git a/contrib/sb-concurrency/tests/test-utils.lisp b/contrib/sb-concurrency/tests/test-utils.lisp
new file mode 100644
index 0000000..6a5e82a
--- /dev/null
+++ b/contrib/sb-concurrency/tests/test-utils.lisp
@@ -0,0 +1,24 @@
+(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
diff --git a/contrib/sb-queue/sb-queue.asd b/contrib/sb-queue/sb-queue.asd
index 78ce92d..aa67ca2 100644
--- a/contrib/sb-queue/sb-queue.asd
+++ b/contrib/sb-queue/sb-queue.asd
@@ -9,25 +9,17 @@
 ;;;; 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
diff --git a/contrib/sb-queue/sb-queue.texinfo b/contrib/sb-queue/sb-queue.texinfo
index 84bd02a..9d74313 100644
--- a/contrib/sb-queue/sb-queue.texinfo
+++ b/contrib/sb-queue/sb-queue.texinfo
@@ -2,19 +2,5 @@
 @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}.)
diff --git a/doc/manual/Makefile b/doc/manual/Makefile
index 2188175..9986cb9 100644
--- a/doc/manual/Makefile
+++ b/doc/manual/Makefile
@@ -15,9 +15,12 @@ DOCSTRINGDIR="docstrings/"
 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
@@ -92,8 +95,15 @@ info: $(INFOFILES)
 # 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
diff --git a/doc/manual/contrib-modules.texinfo b/doc/manual/contrib-modules.texinfo
index 9ea5c67..43f82e3 100644
--- a/doc/manual/contrib-modules.texinfo
+++ b/doc/manual/contrib-modules.texinfo
@@ -5,36 +5,42 @@
 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
+
diff --git a/version.lisp-expr b/version.lisp-expr
index 95f6627..a868992 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.37.17"
+"1.0.37.18"