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 receiver-distribution (n-receivers)
  49   (let* ((aux              (floor n-receivers 2))
  50          (n-recv-msg       (- n-receivers aux))
  51          (n-recv-pend-msgs (floor aux 3))
  52          (n-recv-msg-n-h   (- aux n-recv-pend-msgs)))
  53     (values n-recv-msg
  54             n-recv-msg-n-h
  55             n-recv-pend-msgs)))
  56
  57 (defun test-mailbox-producers-consumers
  58     (&key n-senders n-receivers n-messages interruptor)
  59   (let ((mbox    (make-mailbox))
  60         (counter (make-counter))
  61         (+sleep+ 0.0001)
  62         (+fin-token+ :finish) ; end token for receivers to stop
  63         (+blksize+ 5))        ; "block size" for RECEIVE-PENDING-MESSAGES
  64     (multiple-value-bind (n-recv-msg
  65                           n-recv-msg-n-h
  66                           n-recv-pend-msgs)
  67         ;; We have three groups of receivers, one using
  68         ;; RECEIVE-MESSAGE, one RECEIVE-MESSAGE-NO-HANG, and
  69         ;; another one RECEIVE-PENDING-MESSAGES.
  70         (receiver-distribution n-receivers)
  71       (let ((senders
  72              (make-threads n-senders "SENDER"
  73                            #'(lambda ()
  74                                (dotimes (i n-messages t)
  75                                  (send-message mbox i)
  76                                  (sleep (random +sleep+))))))
  77             (receivers
  78              (flet ((process-msg (msg out)
  79                       (cond
  80                         ((eq msg +fin-token+)
  81                          (funcall out t))
  82                         ((not (< -1 msg n-messages))
  83                          (funcall out nil))
  84                         (t
  85                          (sb-ext:atomic-incf (counter-ref counter))))))
  86                (append
  87                 (make-threads n-recv-msg "RECV-MSG"
  88                   #'(lambda ()
  89                       (sleep (random +sleep+))
  90                       (loop (process-msg (receive-message mbox)
  91                                          #'(lambda (x) (return x))))))
  92                 (make-threads n-recv-pend-msgs "RECV-PEND-MSGS"
  93                   #'(lambda ()
  94                       (loop
  95                         (sleep (random +sleep+))
  96                         (mapc #'(lambda (msg)
  97                                   (process-msg msg #'(lambda (x) (return x))))
  98                               (receive-pending-messages mbox +blksize+)))))
  99                 (make-threads n-recv-msg-n-h "RECV-MSG-NO-HANG"
 100                   #'(lambda ()
 101                       (loop
 102                         (sleep (random +sleep+))
 103                         (multiple-value-bind (msg ok)
 104                             (receive-message-no-hang mbox)
 105                           (when ok
 106                             (process-msg msg #'(lambda (x)
 107                                                  (return x))))))))))))
 108
 109         (when interruptor
 110           (funcall interruptor (append receivers senders)))
 111         (let ((garbage  0)
 112               (errors   0)
 113               (timeouts 0))
 114           (flet ((wait-for (threads)
 115                    (mapc #'(lambda (thread)
 116                              (ecase (timed-join-thread thread)
 117                                ((t))
 118                                ((nil)      (incf garbage))
 119                                ((:aborted) (incf errors))
 120                                ((:timeout) (incf timeouts)
 121                                            (kill-thread thread))))
 122                          threads)))
 123             ;; First wait until all messages are propagating.
 124             (wait-for senders)
 125             ;; Senders are finished, inform and wait for the
 126             ;; receivers.
 127             (loop repeat (+ n-recv-msg
 128                             n-recv-msg-n-h
 129                             (* n-recv-pend-msgs +blksize+))
 130                   ;; The number computed above is an upper bound; if
 131                   ;; we send as many FINs as that, we can be sure that
 132                   ;; every receiver must have got at least one FIN.
 133                   do (send-message mbox +fin-token+))
 134             (wait-for receivers)
 135             ;; We may in fact have sent too many FINs, so make sure
 136             ;; it's only FINs in the mailbox now.
 137             (mapc #'(lambda (msg) (unless (eq msg +fin-token+)
 138                                     (incf garbage)))
 139                   (list-mailbox-messages mbox))
 140             (values  `(:received . ,(counter-ref counter))
 141                      `(:garbage  . ,garbage)
 142                      `(:errors   . ,errors)
 143                      `(:timeouts . ,timeouts))))))))
 144
 145
 146 (deftest mailbox.single-producer-single-consumer
 147     (test-mailbox-producers-consumers :n-senders 1
 148                                       :n-receivers 1
 149                                       :n-messages 10000)
 150   (:received . 10000)
 151   (:garbage  . 0)
 152   (:errors   . 0)
 153   (:timeouts . 0))
 154
 155 (deftest mailbox.single-producer-multiple-consumers
 156     (test-mailbox-producers-consumers :n-senders 1
 157                                       :n-receivers 100
 158                                       :n-messages 10000)
 159   (:received . 10000)
 160   (:garbage  . 0)
 161   (:errors   . 0)
 162   (:timeouts . 0))
 163
 164 (deftest mailbox.multiple-producers-single-consumer
 165     (test-mailbox-producers-consumers :n-senders 100
 166                                       :n-receivers 1
 167                                       :n-messages 100)
 168   (:received . 10000)
 169   (:garbage  . 0)
 170   (:errors   . 0)
 171   (:timeouts . 0))
 172
 173 (deftest mailbox.multiple-producers-multiple-consumers
 174     (test-mailbox-producers-consumers :n-senders 100
 175                                       :n-receivers 100
 176                                       :n-messages 10000)
 177   (:received . 1000000)
 178   (:garbage  . 0)
 179   (:errors   . 0)
 180   (:timeouts . 0))
 181
 182 (deftest mailbox.interrupts-safety.1
 183     (multiple-value-bind (received garbage errors timeouts)
 184         (test-mailbox-producers-consumers
 185          :n-senders 100
 186          :n-receivers 100
 187          :n-messages 1000
 188          :interruptor #'(lambda (threads &aux (n (length threads)))
 189                           ;; 99 so even in the unlikely case that only
 190                           ;; receivers (or only senders) are shot
 191                           ;; dead, there's still one that survives to
 192                           ;; properly end the test.
 193                           (loop repeat 99
 194                                 for victim = (nth (random n) threads)
 195                                 do (kill-thread victim)
 196                                    (sleep (random 0.0001)))))
 197       (values
 198        ;; We may have killed a receiver before it got to incrementing
 199        ;; the counter.
 200        (if (<= (cdr received) 1000000)
 201            `(:received . :ok)
 202            received)
 203        garbage
 204        ;; we may have gotten errors due to our killing spree.
 205        timeouts))
 206   (:received . :ok)
 207   (:garbage  . 0)
 208   (:timeouts . 0))
 209
 210 ) ; #+sb-thread (progn ...