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