X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-concurrency%2Ftests%2Ftest-mailbox.lisp;h=88d3975bc2faffffb0139e11085d6124bc09a8b5;hb=6548750bc1ca4d832afed1744cdc7133b232c6f2;hp=87d76d8ab0619f51e66387cea6e5f531feb2d35d;hpb=ea0735f0b8bab352d6c9797abec19e8c63563cf6;p=sbcl.git

diff --git a/contrib/sb-concurrency/tests/test-mailbox.lisp b/contrib/sb-concurrency/tests/test-mailbox.lisp
index 87d76d8..88d3975 100644
--- a/contrib/sb-concurrency/tests/test-mailbox.lisp
+++ b/contrib/sb-concurrency/tests/test-mailbox.lisp
@@ -39,143 +39,196 @@
   (0 t nil t))
 
 #+sb-thread
+(deftest mailbox-timeouts
+    (let* ((mbox (make-mailbox))
+           (writers (loop for i from 1 upto 20
+                          collect (make-thread
+                                   (lambda (x)
+                                     (loop repeat 50
+                                           do (send-message mbox x)
+                                              (sleep 0.001)))
+                                   :arguments i)))
+           (readers (loop repeat 10
+                          collect (make-thread
+                                   (lambda ()
+                                     (loop while (receive-message mbox :timeout 0.1)
+                                           count t))))))
+      (mapc #'join-thread writers)
+      (apply #'+ (mapcar #'join-thread readers)))
+  1000)
+
+;;; FIXME: Several tests disabled on SunOS due to hangs.
+;;;
+;;; The issues don't seem to have anything to do with mailboxes
+;;; per-se, but are rather related to our usage of signal-unsafe
+;;; pthread functions inside signal handlers.
+#+(and sb-thread (not sunos))
 (progn
 
 ;; Dummy struct for ATOMIC-INCF to work.
 (defstruct counter
   (ref 0 :type sb-vm:word))
 
+(defun receiver-distribution (n-receivers)
+  (let* ((aux              (floor n-receivers 2))
+         (n-recv-msg       (- n-receivers aux))
+         (n-recv-pend-msgs (floor aux 3))
+         (n-recv-msg-n-h   (- aux n-recv-pend-msgs)))
+    (values n-recv-msg
+            n-recv-msg-n-h
+            n-recv-pend-msgs)))
+
 (defun test-mailbox-producers-consumers
-    (&key n-senders n-receivers n-messages mailbox interruptor)
-  (let* ((cnt  (make-counter))
-         (mbox (or mailbox (make-mailbox)))
-         (senders
-          (make-threads n-senders "SENDER"
-            #'(lambda ()
-                (dotimes (i n-messages)
-                  (send-message mbox i)
-                  (sleep (random 0.001))))))
-         (receivers
-          ;; We have three groups of receivers, one using
-          ;; RECEIVE-MESSAGE, one RECEIVE-MESSAGE-NO-HANG, and another
-          ;; one RECEIVE-PENDING-MESSAGES.
-          (let* ((aux              (floor n-receivers 2))
-                 (n-recv-msg       (- n-receivers aux))
-                 (n-recv-pend-msgs (floor aux 3))
-                 (n-recv-msg-n-h   (- aux n-recv-pend-msgs)))
-            (append
-             (make-threads n-recv-msg "RECV-MSG"
-               #'(lambda ()
-                   (sleep (random 0.001))
-                   (handler-case
-                       (loop
-                         (sb-sys:with-deadline (:seconds 1.0)
-                           (let ((msg (receive-message mbox)))
-                             (sb-ext:atomic-incf (counter-ref cnt))
-                             (unless (< -1 msg n-messages)
-                               (hang)))))
-                     (sb-ext:timeout ()))))
-             (make-threads n-recv-pend-msgs "RECV-PEND-MSGS"
-               #'(lambda ()
-                   (sleep (random 0.001))
-                   (dotimes (i 10)
-                     (thread-yield)
-                     (let ((msgs (receive-pending-messages mbox (random 5))))
-                       (mapc #'(lambda (msg)
-                                 (sb-ext:atomic-incf (counter-ref cnt))
-                                 (unless (< -1 msg n-messages)
-                                   (hang)))
-                             msgs)))))
-             (make-threads n-recv-msg-n-h "RECV-MSG-NO-HANG"
-               #'(lambda ()
-                   (sleep (random 0.001))
-                   (dotimes (i 30)
-                     (thread-yield)
-                     (multiple-value-bind (msg ok)
-                         (receive-message-no-hang mbox)
-                       (when ok
-                         (sb-ext:atomic-incf (counter-ref cnt))
-                         (unless (< -1 msg n-messages)
-                           (hang))))))))))
-         (threads (append receivers senders)))
-    (when interruptor (funcall interruptor threads))
-    (mapc #'timed-join-thread threads)
-    (values mbox (counter-ref cnt) (* n-senders n-messages))))
+    (&key n-senders n-receivers n-messages interruptor)
+  (let ((mbox    (make-mailbox))
+        (counter (make-counter))
+        (+sleep+ 0.0001)
+        (+fin-token+ :finish) ; end token for receivers to stop
+        (+blksize+ 5))        ; "block size" for RECEIVE-PENDING-MESSAGES
+    (multiple-value-bind (n-recv-msg
+                          n-recv-msg-n-h
+                          n-recv-pend-msgs)
+        ;; We have three groups of receivers, one using
+        ;; RECEIVE-MESSAGE, one RECEIVE-MESSAGE-NO-HANG, and
+        ;; another one RECEIVE-PENDING-MESSAGES.
+        (receiver-distribution n-receivers)
+      (let ((senders
+             (make-threads n-senders "SENDER"
+                           #'(lambda ()
+                               (dotimes (i n-messages t)
+                                 (send-message mbox i)
+                                 (sleep (random +sleep+))))))
+            (receivers
+             (flet ((process-msg (msg out)
+                      (cond
+                        ((eq msg +fin-token+)
+                         (funcall out t))
+                        ((not (< -1 msg n-messages))
+                         (funcall out nil))
+                        (t
+                         (sb-ext:atomic-incf (counter-ref counter))))))
+               (append
+                (make-threads n-recv-msg "RECV-MSG"
+                  #'(lambda ()
+                      (sleep (random +sleep+))
+                      (loop (process-msg (receive-message mbox)
+                                         #'(lambda (x) (return x))))))
+                (make-threads n-recv-pend-msgs "RECV-PEND-MSGS"
+                  #'(lambda ()
+                      (loop
+                        (sleep (random +sleep+))
+                        (mapc #'(lambda (msg)
+                                  (process-msg msg #'(lambda (x) (return x))))
+                              (receive-pending-messages mbox +blksize+)))))
+                (make-threads n-recv-msg-n-h "RECV-MSG-NO-HANG"
+                  #'(lambda ()
+                      (loop
+                        (sleep (random +sleep+))
+                        (multiple-value-bind (msg ok)
+                            (receive-message-no-hang mbox)
+                          (when ok
+                            (process-msg msg #'(lambda (x)
+                                                 (return x))))))))))))
+
+        (when interruptor
+          (funcall interruptor (append receivers senders)))
+        (let ((garbage  0)
+              (errors   0)
+              (timeouts 0))
+          (flet ((wait-for (threads)
+                   (mapc #'(lambda (thread)
+                             (ecase (timed-join-thread thread)
+                               ((t))
+                               ((nil)      (incf garbage))
+                               ((:aborted) (incf errors))
+                               ((:timeout) (incf timeouts)
+                                           (kill-thread thread))))
+                         threads)))
+            ;; First wait until all messages are propagating.
+            (wait-for senders)
+            ;; Senders are finished, inform and wait for the
+            ;; receivers.
+            (loop repeat (+ n-recv-msg
+                            n-recv-msg-n-h
+                            (* n-recv-pend-msgs +blksize+))
+                  ;; The number computed above is an upper bound; if
+                  ;; we send as many FINs as that, we can be sure that
+                  ;; every receiver must have got at least one FIN.
+                  do (send-message mbox +fin-token+))
+            (wait-for receivers)
+            ;; We may in fact have sent too many FINs, so make sure
+            ;; it's only FINs in the mailbox now.
+            (mapc #'(lambda (msg) (unless (eq msg +fin-token+)
+                                    (incf garbage)))
+                  (list-mailbox-messages mbox))
+            (values  `(:received . ,(counter-ref counter))
+                     `(:garbage  . ,garbage)
+                     `(:errors   . ,errors)
+                     `(:timeouts . ,timeouts))))))))
+
 
 (deftest mailbox.single-producer-single-consumer
-    (multiple-value-bind (mbox received total)
-        (test-mailbox-producers-consumers :n-senders 1
-                                          :n-receivers 1
-                                          :n-messages 10000)
-      (values
-       (= received total)
-       (mailbox-count mbox)
-       (list-mailbox-messages mbox)))
-  t
-  0
-  nil)
+    (test-mailbox-producers-consumers :n-senders 1
+                                      :n-receivers 1
+                                      :n-messages 1000)
+  (:received . 1000)
+  (:garbage  . 0)
+  (:errors   . 0)
+  (:timeouts . 0))
 
 (deftest mailbox.single-producer-multiple-consumers
-    (multiple-value-bind (mbox received total)
-        (test-mailbox-producers-consumers :n-senders 1
-                                          :n-receivers 100
-                                          :n-messages 10000)
-      (values
-       (= received total)
-       (mailbox-count mbox)
-       (list-mailbox-messages mbox)))
-  t
-  0
-  nil)
+    (test-mailbox-producers-consumers :n-senders 1
+                                      :n-receivers 100
+                                      :n-messages 1000)
+  (:received . 1000)
+  (:garbage  . 0)
+  (:errors   . 0)
+  (:timeouts . 0))
 
 (deftest mailbox.multiple-producers-single-consumer
-    (multiple-value-bind (mbox received total)
-        (test-mailbox-producers-consumers :n-senders 100
-                                          :n-receivers 10
-                                          :n-messages 1000)
-      (values
-       (= received total)
-       (mailbox-count mbox)
-       (list-mailbox-messages mbox)))
-  t
-  0
-  nil)
+    (test-mailbox-producers-consumers :n-senders 10
+                                      :n-receivers 1
+                                      :n-messages 100)
+  (:received . 1000)
+  (:garbage  . 0)
+  (:errors   . 0)
+  (:timeouts . 0))
 
 (deftest mailbox.multiple-producers-multiple-consumers
-    (multiple-value-bind (mbox received total)
-        (test-mailbox-producers-consumers :n-senders 100
-                                          :n-receivers 100
-                                          :n-messages 1000)
-      (values
-       (= received total)
-       (mailbox-count mbox)
-       (list-mailbox-messages mbox)))
-  t
-  0
-  nil)
+    (test-mailbox-producers-consumers :n-senders 100
+                                      :n-receivers 100
+                                      :n-messages 1000)
+  (:received . 100000)
+  (:garbage  . 0)
+  (:errors   . 0)
+  (:timeouts . 0))
 
 (deftest mailbox.interrupts-safety.1
-    (multiple-value-bind (mbox received total)
+    (multiple-value-bind (received garbage errors timeouts)
         (test-mailbox-producers-consumers
          :n-senders 100
          :n-receivers 100
          :n-messages 1000
-         :interruptor #'(lambda (threads)
-                          (let ((n (length threads)))
-                            ;; 99 so even in the unlikely case that only
-                            ;; receivers (or only senders) are shot
-                            ;; dead, there's still one that survives to
-                            ;; properly end the test.
-                            (loop repeat 99 do
-                              (kill-thread (nth (random n) threads))))))
+         :interruptor #'(lambda (threads &aux (n (length threads)))
+                          ;; 99 so even in the unlikely case that only
+                          ;; receivers (or only senders) are shot
+                          ;; dead, there's still one that survives to
+                          ;; properly end the test.
+                          (loop repeat 99
+                                for victim = (nth (random n) threads)
+                                do (kill-thread victim)
+                                   (sleep (random 0.0001)))))
       (values
        ;; We may have killed a receiver before it got to incrementing
        ;; the counter.
-       (<= received total)
-       (mailbox-count mbox)
-       (list-mailbox-messages mbox)))
-  t
-  0
-  nil)
+       (if (<= (cdr received) 1000000)
+           `(:received . :ok)
+           received)
+       garbage
+       ;; we may have gotten errors due to our killing spree.
+       timeouts))
+  (:received . :ok)
+  (:garbage  . 0)
+  (:timeouts . 0))
 
-) ; #+sb-thread (progn ...
\ No newline at end of file
+) ; #+sb-thread (progn ...