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