contrib/sb-concurrency/tests/test-mailbox.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was written at
   5 ;;;; Carnegie Mellon University and released into the public domain. The
   6 ;;;; software is in the public domain and is provided with absolutely no
   7 ;;;; warranty. See the COPYING and CREDITS files for more information.
   8
   9 (in-package :sb-concurrency-test)
  10
  11 (deftest mailbox-trivia.1
  12     (values (mailboxp (make-mailbox))
  13             (mailboxp 42))
  14   t
  15   nil)
  16
  17 (deftest mailbox-trivia.2
  18     (let ((mbox1 (make-mailbox :name "foof"))
  19           (mbox2 (make-mailbox)))
  20       (values (mailbox-name mbox1)
  21               (mailbox-name mbox2)))
  22   "foof"
  23   nil)
  24
  25 (deftest mailbox-trivia.3
  26     (flet ((test (initial-contents)
  27              (let ((mbox (make-mailbox :initial-contents initial-contents)))
  28                (list (mailbox-count mbox)
  29                      (mailbox-empty-p mbox)
  30                      (list-mailbox-messages mbox)
  31                      (eq (list-mailbox-messages mbox) initial-contents)))))
  32       (values (test '(1 2 3))
  33               (test #(1 2 3))
  34               (test "123")
  35               (test nil)))
  36   (3 nil (1 2 3) nil)
  37   (3 nil (1 2 3) nil)
  38   (3 nil (#\1 #\2 #\3) nil)
  39   (0 t nil t))
  40
  41 #+sb-thread
  42 (progn
  43
  44 ;; Dummy struct for ATOMIC-INCF to work.
  45 (defstruct counter
  46   (ref 0 :type sb-vm:word))
  47
  48 (defun test-mailbox-producers-consumers
  49     (&key n-senders n-receivers n-messages mailbox interruptor)
  50   (let* ((cnt  (make-counter))
  51          (mbox (or mailbox (make-mailbox)))
  52          (senders
  53           (make-threads n-senders "SENDER"
  54             #'(lambda ()
  55                 (dotimes (i n-messages)
  56                   (send-message mbox i)
  57                   (sleep (random 0.001))))))
  58          (receivers
  59           ;; We have three groups of receivers, one using
  60           ;; RECEIVE-MESSAGE, one RECEIVE-MESSAGE-NO-HANG, and another
  61           ;; one RECEIVE-PENDING-MESSAGES.
  62           (let* ((aux              (floor n-receivers 2))
  63                  (n-recv-msg       (- n-receivers aux))
  64                  (n-recv-pend-msgs (floor aux 3))
  65                  (n-recv-msg-n-h   (- aux n-recv-pend-msgs)))
  66             (append
  67              (make-threads n-recv-msg "RECV-MSG"
  68                #'(lambda ()
  69                    (sleep (random 0.001))
  70                    (handler-case
  71                        (loop
  72                          (sb-sys:with-deadline (:seconds 1.0)
  73                            (let ((msg (receive-message mbox)))
  74                              (sb-ext:atomic-incf (counter-ref cnt))
  75                              (unless (< -1 msg n-messages)
  76                                (hang)))))
  77                      (sb-ext:timeout ()))))
  78              (make-threads n-recv-pend-msgs "RECV-PEND-MSGS"
  79                #'(lambda ()
  80                    (sleep (random 0.001))
  81                    (dotimes (i 10)
  82                      (thread-yield)
  83                      (let ((msgs (receive-pending-messages mbox (random 5))))
  84                        (mapc #'(lambda (msg)
  85                                  (sb-ext:atomic-incf (counter-ref cnt))
  86                                  (unless (< -1 msg n-messages)
  87                                    (hang)))
  88                              msgs)))))
  89              (make-threads n-recv-msg-n-h "RECV-MSG-NO-HANG"
  90                #'(lambda ()
  91                    (sleep (random 0.001))
  92                    (dotimes (i 30)
  93                      (thread-yield)
  94                      (multiple-value-bind (msg ok)
  95                          (receive-message-no-hang mbox)
  96                        (when ok
  97                          (sb-ext:atomic-incf (counter-ref cnt))
  98                          (unless (< -1 msg n-messages)
  99                            (hang))))))))))
 100          (threads (append receivers senders)))
 101     (when interruptor (funcall interruptor threads))
 102     (mapc #'timed-join-thread threads)
 103     (values mbox (counter-ref cnt) (* n-senders n-messages))))
 104
 105 (deftest mailbox.single-producer-single-consumer
 106     (multiple-value-bind (mbox received total)
 107         (test-mailbox-producers-consumers :n-senders 1
 108                                           :n-receivers 1
 109                                           :n-messages 10000)
 110       (values
 111        (= received total)
 112        (mailbox-count mbox)
 113        (list-mailbox-messages mbox)))
 114   t
 115   0
 116   nil)
 117
 118 (deftest mailbox.single-producer-multiple-consumers
 119     (multiple-value-bind (mbox received total)
 120         (test-mailbox-producers-consumers :n-senders 1
 121                                           :n-receivers 100
 122                                           :n-messages 10000)
 123       (values
 124        (= received total)
 125        (mailbox-count mbox)
 126        (list-mailbox-messages mbox)))
 127   t
 128   0
 129   nil)
 130
 131 (deftest mailbox.multiple-producers-single-consumer
 132     (multiple-value-bind (mbox received total)
 133         (test-mailbox-producers-consumers :n-senders 100
 134                                           :n-receivers 10
 135                                           :n-messages 1000)
 136       (values
 137        (= received total)
 138        (mailbox-count mbox)
 139        (list-mailbox-messages mbox)))
 140   t
 141   0
 142   nil)
 143
 144 (deftest mailbox.multiple-producers-multiple-consumers
 145     (multiple-value-bind (mbox received total)
 146         (test-mailbox-producers-consumers :n-senders 100
 147                                           :n-receivers 100
 148                                           :n-messages 1000)
 149       (values
 150        (= received total)
 151        (mailbox-count mbox)
 152        (list-mailbox-messages mbox)))
 153   t
 154   0
 155   nil)
 156
 157 (deftest mailbox.interrupts-safety.1
 158     (multiple-value-bind (mbox received total)
 159         (test-mailbox-producers-consumers
 160          :n-senders 100
 161          :n-receivers 100
 162          :n-messages 1000
 163          :interruptor #'(lambda (threads)
 164                           (let ((n (length threads)))
 165                             ;; 99 so even in the unlikely case that only
 166                             ;; receivers (or only senders) are shot
 167                             ;; dead, there's still one that survives to
 168                             ;; properly end the test.
 169                             (loop repeat 99 do
 170                               (kill-thread (nth (random n) threads))))))
 171       (values
 172        ;; We may have killed a receiver before it got to incrementing
 173        ;; the counter.
 174        (<= received total)
 175        (mailbox-count mbox)
 176        (list-mailbox-messages mbox)))
 177   t
 178   0
 179   nil)
 180
 181 ) ; #+sb-thread (progn ...