[gnunet-scheme] 144/324: mq: Test message cancellation.

[gnunet]

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

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

commit 6062cff67957274d5da2b919dcd1bec3e6b27403
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Thu Jun 17 23:03:25 2021 +0200

    mq: Test message cancellation.
    
    * tests/mq.scm
      ("envelopes do not keep a strong reference to the message queue")
      ("cancelling envelopes eventually frees memory even if message
      sender is dead")
      ("the one-by-one message sender removes cancelled envelopes")
      ("the (approximate) cancellation count is accurate, when not
      sending, even when cancelling concurrently (also, uncancelled
      messages are not lost)"): New tests.
      (count-guardian/cancelled, count-guardian/uncancelled)
      (sender/no-cancelled): New procedures.
---
 tests/mq.scm | 235 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 235 insertions(+)

diff --git a/tests/mq.scm b/tests/mq.scm
index 25038b1..ef94295 100644
--- a/tests/mq.scm
+++ b/tests/mq.scm
@@ -24,6 +24,7 @@
 (define-module (tests mq))
 
 (use-modules (ice-9 control)
+            (tests utils) ; for conservative-gc?
             (fibers conditions)
             (fibers)
             (srfi srfi-1)
@@ -297,6 +298,8 @@ invocations, and at other times doing nothing."
 ;;    there, as the 'maximum reasonable bound'
 ;;    is just a wild guess and not some exact
 ;;    cut-off.
+;;
+;; Cancellation will be tested separately.
 
 (define random/thread
   (fluid->parameter (make-unbound-fluid)))
@@ -693,3 +696,235 @@ with @code{x}."
       #:unwind-for-type 'out-of-memory)
     (and enqueued? exceptional
         (not enveloped))))
+
+
+
+;; Message cancellation.
+;;
+;; Cancellation is already tested in tests/envelope.scm.
+;; However, the interaction with message queues has not
+;; yet been tested.
+
+;; This test detected (not detected by previous tests):
+;;   * the cdr of the contents of messages+garbage/box
+;;     being initialised incorrectly in make-message-queue
+;;   * using car instead of cdr in increment-garbage&maybe-cleanup
+
+(test-assert "envelopes do not keep a strong reference to the message queue"
+  (let* ((mq (make-message-queue #f #f (lambda _ (values))))
+        (mq-guard (make-guardian))
+        (envelope (send-message! mq (index->dummy 0))))
+    (mq-guard mq)
+    (attempt-cancel!
+     envelope
+     ((now-cancelled)
+      (gc)
+      (->bool (mq-guard)))
+     ((already-cancelled) (error "what/cancelled"))
+     ((already-sent) (error "what/sent")))))
+
+(define (count-guardian/cancelled guardian)
+  "Count how many elements are present in @var{guardian}.
+While we're at it, verify each element is a cancelled envelope."
+  (let loop ((n 0))
+    (let ((e (guardian)))
+      (cond ((not e) n)
+           ((envelope-peek-cancelled? e) (loop (+ n 1)))
+           (#t (error "a not-cancelled envelope was freed!"))))))
+
+(define (count-guardian/uncancelled guardian)
+  "Count how many elements are present in @var{guardian}.
+While we're at it, verify each element is an uncancelled envelope."
+  (let loop ((n 0))
+    (let ((e (guardian)))
+      (cond ((not e) n)
+           ((not (envelope-peek-cancelled? e)) (loop (+ n 1)))
+           (#t (error "a cancelled envelope was freed!"))))))
+
+;; This is a variant of
+;; "the one-by-one message sender removes cancelled envelopes",
+;; using guardians, and purely testing the cancelling code, and
+;; not the sending code.
+;;
+;; It detects the following mutations:
+;;   * removing (spin queue+garbage) after swap! in the 
'envelope-peek-cancelled?'
+;;     branch of 'make-one-by-one-sender'
+(test-assert "cancelling envelopes eventually frees memory even if message 
sender is dead"
+  (let* ((mq (make-message-queue #f #f (lambda _ (values))))
+        (cancelled-guard (make-guardian))
+        (uncancelled-guard (make-guardian)))
+    ;; Add a bunch of messages.
+    (let ((messages
+          (map (lambda (i)
+                 (send-message! mq (index->dummy i)))
+               (iota 50))))
+      ;; Cancel most of them.  This should trigger collection of
+      ;; cancelled envelopes.
+      (for-each
+       (lambda (e)
+        (cancelled-guard e)
+        (attempt-cancel!
+         e
+         ((now-cancelled) (values))
+         ((already-cancelled) (error "what/cancelled"))
+         ((already-sent) (error "what/sent"))))
+       (list-head messages 40)))
+    ;; Move freed envelopes to the guardian.
+    (gc)
+    ;; How many were freed?
+    (let ((freed/cancelled (count-guardian/cancelled cancelled-guard))
+         (freed/uncancelled (count-guardian/uncancelled uncancelled-guard))
+         (cancelled 40)
+         (total 50))
+      (pk 'total total 'cancelled cancelled 'freed/cancelled freed/cancelled
+         'freed/uncancelled freed/uncancelled
+         'queue-length (message-queue-length mq))
+      ;; Only cancelled messages were supposed to be freed.
+      (assert (= freed/uncancelled 0))
+      (assert (<= freed/cancelled cancelled))
+      ;; A large fraction of cancelled messages should be freed.
+      (assert (>= (/ freed/cancelled cancelled) 7/8))
+      ;; If the GC is exact, all messages removed from the message
+      ;; queue (due to cancelling) should be removed.
+      (unless (conservative-gc?)
+       (assert (= freed/cancelled (- total (message-queue-length mq)))))
+      #t)))
+
+(define sender/no-cancelled
+  (make-one-by-one-sender
+   (lambda (e)
+     (pk 'ee e)
+     (assert (not (envelope-peek-cancelled? e)))
+     (values))))
+
+;; Not strictly necessary (and also undocumented), but this should
+;; improve the accuracy of the garbage counter. Maybe not trying
+;; to send useless (cancelled) envelopes could help with performance
+;; as well (untested)?
+;;
+;; Also, this  caught a bug in (gnu gnunet mq) -- the procedure returned
+;; by 'make-one-by-one-sender' went into an infinite loop if it encountered
+;; a cancelled envelope.
+;;
+;; This tests detects negating the test
+;;   (eq? old (swap! old (cons old-queue incremented-garbage)))
+;; in increment-garbage&maybe-cleanup.
+
+(test-assert "the one-by-one message sender removes cancelled envelopes"
+  (let* ((flush? (make-parameter #f))
+        (sender (make-sender/choice flush? (lambda _ (values))
+                                    sender/no-cancelled))
+        (mq (make-message-queue #f #f sender)))
+    ;; Fill the queue with many uncancelled messages, such that
+    ;; the logic for collecting cancelled envelopes doesn't kick in too early.
+    (do ((i 0 (+ i 1)))
+       ((>= i 30))
+      (send-message! mq (index->dummy i)))
+    (assert (= (message-queue-length mq) 30))
+    ;; Now add some envelopes to the queue & cancel them.
+    (do ((i 0 (+ i 1)))
+       ((>= i 4))
+      (attempt-cancel!
+       (send-message! mq (index->dummy (+ 30 i)))
+       ((now-cancelled) (values))
+       ((already-cancelled) (error "what / cancelled"))
+       ((already-sent) (error "what / sent"))))
+    (assert (= (message-queue-length mq) 34))
+    (parameterize ((flush? #t))
+      (try-send-again! mq))
+    (assert (= (message-queue-length mq) 0))
+    (assert (= (%message-queue-garbagitude mq) 0))
+    #t))
+
+;; This is a variation of "nothing lost when sending concurrently",
+;; but for cancelation.
+;;
+;; This test fails in case of the following mutations:
+;;   * replace 0 with 1 in (or some other number) in
+;;     (swap! old (cons filtered 0))
+;;     in increment-garbage&maybe-cleanup
+(test-assert "the (approximate) cancellation count is accurate, when not 
sending, even when cancelling concurrently (also, uncancelled messages are not 
lost)"
+  (let* ((messages/cancellation 10000)
+        (n/not-cancelled #f)
+        (flush? (make-parameter #f))
+        (sender/check (lambda (e)
+                        (unless (envelope-peek-cancelled? e)
+                          (set! n/not-cancelled (+ 1 n/not-cancelled)))
+                        (values)))
+        (sender (make-sender/choice flush?
+                                    (lambda _ (values))
+                                    (make-one-by-one-sender sender/check)))
+        (mq (make-message-queue #f #f sender))
+        (ready? (make-condition))
+        (done? (vector-unfold
+                (lambda (_) (make-condition))
+                (/ messages/cancellation 2)))
+        (messages
+         (with-exception-handler
+             (lambda (e)
+               (if (overly-full-queue-warning? e)
+                   (values)
+                   (raise-exception e #:continuable? #t)))
+           (lambda ()
+             (vector-unfold (compose (cut send-message! mq <>)
+                                     index->dummy)
+                            messages/cancellation)))))
+    (run-fibers
+     (lambda ()
+       ;; Cancel half of the messages, concurrently.
+       ;; Only half of all the messages are cancelled,
+       ;; to avoid resetting the garbage counter.
+       (vector-for-each
+       (lambda (i done? message)
+         (when (< i (/ messages/cancellation 2))
+           (spawn-fiber
+            (lambda ()
+              (wait ready?)
+              (attempt-cancel!
+               message
+               ((now-cancelled)
+                (signal-condition! done?)
+                (values))
+               ((already-cancelled)
+                (signal-condition! done?)
+                (error "what/cancelled"))
+               ((already-sent)
+                (signal-condition! done?)
+                (error "what/sent")))))))
+       done? messages)
+       (signal-condition! ready?)
+       (vector-for-each (lambda (_ c) (wait c)) done?))
+     #:hz 4000)
+    ;; Verify the estimate is accurate, at least in this
+    ;; situation.
+    (assert (= (pk 'garbagitude (%message-queue-garbagitude mq))
+              (pk 'expected (/ messages/cancellation 2))))
+    ;; Cancel more messages (until 7/8 are cancelled),
+    ;; to trigger collection. While we're at, verify
+    ;; the estimate is still correct.
+    (do ((i (/ messages/cancellation 2) (+ i 1)))
+       ((>= (/ i messages/cancellation) 7/8))
+      (attempt-cancel!
+       (vector-ref messages (pk 'iiii i))
+       ((now-cancelled)
+       ;; 3/4 is the (arbitrary) ratio at which
+       ;; the garbage is thrown out
+       (if (< (* 4 i) (* 3 messages/cancellation))
+           (assert (= (%message-queue-garbagitude mq)
+                      (+ i 1)))
+           (assert (= (%message-queue-garbagitude mq)
+                      (- i (* 3/4 messages/cancellation))))))
+       ((already-cancelled) (error "what/cancelled2"))
+       ((already-sent) (error "what/sent2"))))
+    ;; Now send the envelopes, to verify uncancelled messages
+    ;; are still in the queue.
+    (parameterize ((flush? #t))
+      (set! n/not-cancelled 0)
+      (try-send-again! mq))
+    (assert (= n/not-cancelled (* 1/8 messages/cancellation)))
+    ;; As everything has been removed from the queue,
+    ;; the estimate should now be zero.
+    (assert (= (pk 'final-garbagitude (%message-queue-garbagitude mq))
+              0))
+    #t))
+

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