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