[gnunet-scheme] branch master updated (310f715 -> cb740f7)

[gnunet]

This is an automated email from the git hooks/post-receive script.

maxime-devos pushed a change to branch master
in repository gnunet-scheme.

    from 310f715  tests/cadet: Partially test the 'acknowledgement' mechanism.
     new b0e84ed  tests/cadet: Correct use of 'cond'.
     new 64607ac  tests/cadet: Fix book-keeping of the number of 
acknowledgements.
     new 12c457f  tests/cadet: Verify the messages are actually ever sent.
     new cb740f7  tests/cadet: Simplify test by removing atomics.

The 4 revisions listed above as "new" are entirely new to this
repository and will be described in separate emails.  The revisions
listed as "add" were already present in the repository and have only
been added to this reference.


Summary of changes:
 tests/cadet.scm | 82 ++++++++++++++++++++++++++++++++++++++-------------------
 1 file changed, 55 insertions(+), 27 deletions(-)

diff --git a/tests/cadet.scm b/tests/cadet.scm
index 5a59111..b883f5d 100644
--- a/tests/cadet.scm
+++ b/tests/cadet.scm
@@ -38,7 +38,6 @@
        (rnrs bytevectors)
        (only (fibers scheduler)
              yield-current-task)
-       (ice-9 atomic)
        (ice-9 match)
        (srfi srfi-8)
        (srfi srfi-64)
@@ -272,11 +271,21 @@
   ;;
   ;; TODO: actually check the first once.
   (property ((messages+acknowledgements
-             ($list ($arbitrary-lift vector
-                                     ;; Number of messages to send
-                                     $natural
-                                     ;; Number of acknowledgements to send
-                                     $natural))))
+             ($list
+              ($choose
+               ;; 'error': we aren't generating functions, so it will
+               ;; be unused.
+               (error ($arbitrary-lift vector
+                                       ;; Number of messages to send
+                                       $natural
+                                       ;; Number of acknowledgements to send
+                                       $natural))
+               ;; 'synchronize': Verify that the messages are going to the
+               ;; server.  This is not done after every round, because that
+               ;; would reduce the amount of concurrency and hence the scope
+               ;; of the test.
+               (error ($const 'synchronize))))))
+    (pk 'iter) ; indicate it's not hanging
     (let ((server-channel (make-channel)))
       (call-with-services/fibers
        `(("cadet" .
@@ -295,7 +304,8 @@
                  (let loop2 ((n n))
                    (cond ((<= n 0)
                           (loop))
-                         ((send-message! message-queue acknowledgement)
+                         (#true
+                          (send-message! message-queue acknowledgement)
                           (loop2 (- n 1))))))
                 ('stop (values)))))))
        (lambda (config spawn-fiber)
@@ -304,13 +314,11 @@
           (open-channel! server address0 (message-handlers)))
         (define message-queue
           (channel-message-queue channel))
-        (define n-added/non-atomic 0) ; how many messages have been added to 
the queue so far
-        (define n-added (make-atomic-box 0))
+        ;; No atomic boxes are required here even though they are accessed and 
mutated
+        ;; from multiple fibers, because of #:parallelism 0 and #:hz 0.
+        (define n-added 0) ; how many messages have been added to the queue so 
far
         (define n-sent 0) ; how many of those messages have been irrevocably 
sent
-        (define total-acknowledgements
-          (make-atomic-box 0))
-        (define total-acknowledgements/non-atomic
-          0)
+        (define total-acknowledgements 0)
         (define (make-notify-sent! i)
           (lambda ()
             ;; Verify that messages were sent in-order,
@@ -321,32 +329,52 @@
             ;; messages are sent sequentially.
             (set! n-sent (+ n-sent 1))
             ;; an additional check.
-            ;; Memory order: acquire.
-            (assert (<= n-sent (atomic-box-ref n-added)))
+            (assert (<= n-sent n-added))
             ;; Verify that the number of acknowledgements is respected.
-            ;; Memory order: acquire.
-            (assert (<= n-sent (atomic-box-ref total-acknowledgements)))
-                  (values)))
+            (assert (<= n-sent total-acknowledgements))
+            (values)))
         (let loop ((remaining messages+acknowledgements))
           (match remaining
+            (('synchronize . remaining)
+             ;; Check that all the messages that could be sent have been sent
+             ;; (no corking was requested, and the previous loop simulated
+             ;; passage of some time).
+             (let loop ((old-to-be-sent +inf.0))
+               (define new-to-be-sent
+                 (- (min total-acknowledgements n-added) n-sent))
+               (assert (<= 0 new-to-be-sent))
+               (assert (< new-to-be-sent old-to-be-sent)) ; bail out if no 
progress is made
+               (when (< 0 new-to-be-sent)
+                 ;; Give the various fibers a chance to process the messages. 
The allowed
+                 ;; amount of context switched is proportional to the number 
of messages
+                 ;; that still need to be sent. The number 16 is an 
over-approximation,
+                 ;; the exact value doesn't matter to this test.
+                 (let loop* ((n (* 16 (+ 1 new-to-be-sent))))
+                   (when (> n 0)
+                     (yield-current-task)
+                     (loop* (- n 1))))
+                 (loop new-to-be-sent)))
+             (loop remaining))
             ((#(n-new-messages n-new-acknowledgements) . remaining)
              (put-message server-channel n-new-acknowledgements)
+             (set! total-acknowledgements
+                   (+ n-new-acknowledgements total-acknowledgements))
              (let loop2 ((k 0))
                (cond ((< k n-new-messages)
-                      (set! total-acknowledgements/non-atomic
-                            (+ 1 total-acknowledgements/non-atomic))
-                      (set! n-added/non-atomic (+ 1 n-added/non-atomic))
-                      ;; Memory order: release
-                      (atomic-box-set! total-acknowledgements 
total-acknowledgements/non-atomic)
-                      ;; Memory order: release
-                      (atomic-box-set! n-added n-added/non-atomic)
+                      (set! n-added (+ 1 n-added))
                       (send-message! message-queue message
                                      #:notify-sent!
-                                     (make-notify-sent! (- n-added/non-atomic 
1)))
+                                     (make-notify-sent! (- n-added 1)))
                       (loop2 (+ k 1)))
                      (#true (loop remaining)))))
             (()
              (put-message server-channel 'stop)
-             #true))))))))) ; done!
+             #true)))) ; done!
+       ;; yield-current-task in a loop only works when singly-threaded.
+       ;; The code manipulating the counters above plays a bit loose with 
concurrency
+       ;; concerns, hence both #:hz 0 and #:parallelism 1 is required to avoid
+       ;; potential false positives.
+       #:hz 0
+       #:parallelism 1)))))
 
 (test-end "CADET")

-- 
To stop receiving notification emails like this one, please contact
gnunet@gnunet.org.