[gnunet-scheme] 153/324: concurrency: repeated-conditions: New module.

[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 36b0f13af48c25ceace071e4617549ad7d6bd4f9
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Sun Jul 4 22:38:00 2021 +0200

    concurrency: repeated-conditions: New module.
    
    This will be used in the generic message queue implementation.
    It behaves slightly differently from fibers' conditions.
    The documentation is bad but I'm not feeling particularily
    inspired.
    
    I'm avoiding (let^ ((_ ...) ...) ...) because that's unusable
    know when the auxilliary syntax '_' has been imported from
    (rnrs base) ... something to fix on 'master'.
    
    The tests didn't detect much except some spelling mistakes,
    using the record instead of a field of the record ... nothing
    that wouldn't be detected once the module is used ‘for real’.
    
    * Makefile.am
      (modules): Add new module.
      (SCM_TESTS): Add test for new module.
    * README.org (Modules): Document new module a little.
    * gnu/gnunet/concurrency/repeated-condition.scm
      (<repeated-condition>, make-repeated-condition)
      repeated-condition?): New record type.
      (prepare-await-trigger!, await-trigger!, trigger-condition!): New
      procedures.
    * tests/repeated-condition.scm
      (expected-blocking-operation): Copy from 'tests/update.scm'
      ("repeated conditions are condition?")
      ("initially, await-trigger! blocks")
      ("trigger-condition! & await-trigger! completes, sequential")
      ("likewise, but prepare awaiting the trigger before triggering")
      ("await-trigger! hangs the second time (without
      trigger-condition!)")
      ("concurrent ping pong completes"): New tests.
---
 Makefile.am                                   |   2 +
 README.org                                    |   2 +
 gnu/gnunet/concurrency/repeated-condition.scm |  95 +++++++++++++++++
 tests/repeated-condition.scm                  | 143 ++++++++++++++++++++++++++
 4 files changed, 242 insertions(+)

diff --git a/Makefile.am b/Makefile.am
index d18a58d..a1f4943 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -36,6 +36,7 @@ modules = \
   gnu/gnunet/message/protocols.scm \
   \
   gnu/gnunet/concurrency/update.scm \
+  gnu/gnunet/concurrency/repeated-condition.scm \
   \
   gnu/gnunet/mq/envelope.scm \
   gnu/gnunet/mq/handler.scm \
@@ -101,6 +102,7 @@ SCM_TESTS = \
   tests/message-handler.scm \
   tests/mq.scm \
   tests/update.scm \
+  tests/repeated-condition.scm \
   tests/bv-slice.scm \
   tests/cmsg.scm \
   tests/config-parser.scm \
diff --git a/README.org b/README.org
index b42706a..ad11af7 100644
--- a/README.org
+++ b/README.org
@@ -50,6 +50,8 @@
     can be waited upon.
   + gnu/gnunet/utils/platform-enum.scm: Platform-specific
     C-style enum values.
+  + gnu/gnunet/concurrency/repeated-condition: different type
+    of conditions (TODO describe better)
 ** Tags
    + spec: it is unknown if this will turn out to be a practical abstraction.
    + why: it remains to be seen if these modules will have any use
diff --git a/gnu/gnunet/concurrency/repeated-condition.scm 
b/gnu/gnunet/concurrency/repeated-condition.scm
new file mode 100644
index 0000000..4dd3cf9
--- /dev/null
+++ b/gnu/gnunet/concurrency/repeated-condition.scm
@@ -0,0 +1,95 @@
+;; This file is part of scheme-GNUnet.
+;; Copyright (C) 2021 Maxime Devos
+;;
+;; scheme-GNUnet is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU Affero General Public License as published
+;; by the Free Software Foundation, either version 3 of the License,
+;; or (at your option) any later version.
+;;
+;; scheme-GNUnet is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Affero General Public License for more details.
+;;
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;
+;; SPDX-License-Identifier: AGPL3.0-or-later
+
+;; I'm not sure how to document this.
+(define-library (gnu gnunet concurrency repeated-condition)
+  (export make-repeated-condition repeated-condition?
+         prepare-await-trigger! await-trigger! trigger-condition!)
+  (import (only (rnrs records syntactic)
+               define-record-type)
+         (only (guile) pk quote)
+         (only (rnrs base)
+               begin lambda define eq? not values)
+         (only (gnu gnunet utils hat-let)
+               let^)
+         (prefix (only (fibers conditions)
+                       make-condition signal-condition! wait-operation)
+                 cvar:)
+         (only (fibers operations)
+               choice-operation perform-operation)
+         (only (ice-9 atomic)
+               make-atomic-box atomic-box-ref
+               atomic-box-compare-and-swap!))
+  (begin
+    ;; TODO: is this ‘edge-triggered’?  Does this behave like
+    ;; POSIX condition variables?
+    (define-record-type
+       (<repeated-condition> make-repeated-condition repeated-condition?)
+      (fields (immutable cvar-box rcvar-cvar-box))
+      (protocol
+       (lambda (%make)
+        (lambda ()
+          "Make a fresh ‘repeated condition’.
+
+Repeated conditions are a variant of fiber's conditions.
+They can be signalled and waited upon like regular conditions.
+However, the semantics of waiting multiple times are different.
+
+Each wait creates a ‘waiting event’.  TODO study the literature
+for some proper and clear vocabulary."
+          (%make (make-atomic-box (cvar:make-condition)))))))
+
+    ;; Concurrent 'await-trigger!' are not supported!
+    ;; Likewise, this procedure should not be interrupted.
+    ;; (system-async-mark and fibers scheduling are fine though.)
+    ;;
+    ;; Each time, a new operation must be made with this procedure.
+    ;; Old operations may not be re-used.  The previous operation
+    ;; must be performed before creating the next one.
+    (define (prepare-await-trigger! rcvar)
+      (let^ ((! cvar-box (rcvar-cvar-box rcvar))
+            (! next (cvar:make-condition))
+            (! previous (atomic-box-ref cvar-box))
+            (! operation
+               (choice-operation
+                (cvar:wait-operation previous)
+                ;; Include 'next'.  Otherwise, ???.
+                (cvar:wait-operation next)))
+            ;; Tell 'trigger-condition!' about the new
+            ;; condition.
+            (! next-previous
+               (atomic-box-compare-and-swap! cvar-box previous next))
+            ;; await-trigger! may not be used concurrently,
+            ;; so this assert should succeed.
+            (!! (eq? previous next-previous)))
+           operation))
+
+    (define (await-trigger! rcvar)
+      (perform-operation (prepare-await-trigger! rcvar)))
+
+    (define (trigger-condition! rcvar)
+      (let^ ((! cvar-box (rcvar-cvar-box rcvar))
+            (/o/ spin (cvar (atomic-box-ref cvar-box)))
+            (<-- (_) (cvar:signal-condition! cvar))
+            ;; Verify the condition hasn't changed.
+            (! next-old
+               (atomic-box-compare-and-swap! cvar-box cvar cvar))
+            ;; If it did change, we notified the wrong condition,
+            ;; so retry!
+            (? (not next-old) (spin next-old)))
+           (values)))))
diff --git a/tests/repeated-condition.scm b/tests/repeated-condition.scm
new file mode 100644
index 0000000..9ec322f
--- /dev/null
+++ b/tests/repeated-condition.scm
@@ -0,0 +1,143 @@
+;; This file is part of scheme-GNUnet.
+;; Copyright (C) 2021 Maxime Devos
+;;
+;; scheme-GNUnet is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU Affero General Public License as published
+;; by the Free Software Foundation, either version 3 of the License,
+;; or (at your option) any later version.
+;;
+;; scheme-GNUnet is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Affero General Public License for more details.
+;;
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;
+;; SPDX-License-Identifier: AGPL3.0-or-later
+
+(import (gnu gnunet concurrency repeated-condition)
+        (gnu gnunet utils hat-let)
+        (fibers operations)
+        (fibers conditions)
+        (fibers timers)
+       (fibers)
+       (srfi srfi-43))
+
+;; Copied from 'tests/update.scm'.
+;; TODO abstract this?
+(define expected-blocking-operation
+  (wrap-operation (sleep-operation 1e-4)
+                 (lambda () 'blocking)))
+
+;; First some basic sequential tests, ignoring memory ordering
+;; issues and other concurrency.
+
+(test-begin "repeated condition")
+
+(test-assert "repeated conditions are condition?"
+  (repeated-condition? (make-repeated-condition)))
+
+(test-equal "initially, await-trigger! blocks"
+  '(blocking)
+  (let^ ((<-- (rcvar) (make-repeated-condition))
+        (<-- (operation) (prepare-await-trigger! rcvar)))
+       (call-with-values
+           (lambda ()
+             (perform-operation
+              (choice-operation operation expected-blocking-operation)))
+         list)))
+
+(test-assert "trigger-condition! & await-trigger! completes, sequential"
+  (let^ ((<-- (rcvar) (make-repeated-condition))
+        (<-- () (trigger-condition! rcvar))
+        (<-- () (await-trigger! rcvar)))
+       #t))
+
+(test-assert "likewise, but multiple times"
+  (let^ ((<-- (rcvar) (make-repeated-condition))
+        (/o/ loop (todo 10))
+        (<-- () (trigger-condition! rcvar))
+        (<-- () (await-trigger! rcvar))
+        (? (> todo 1)
+           (loop (- todo 1))))
+       #t))
+
+(test-assert "likewise, but prepare awaiting the trigger before triggering"
+  (let^ ((<-- (rcvar) (make-repeated-condition))
+        (<-- (operation) (prepare-await-trigger! rcvar))
+        (<-- () (trigger-condition! rcvar))
+        (<-- () (perform-operation operation)))
+       #t))
+
+;; This is a departure from fiber's conditions:
+;; ‘repeated conditions’ are re-usable.
+
+(test-equal "await-trigger! hangs the second time (without trigger-condition!)"
+  '(blocking)
+  (let^ ((<-- (rcvar) (make-repeated-condition))
+        (<-- () (trigger-condition! rcvar))
+        (<-- () (await-trigger! rcvar))
+        (<-- (operation) (prepare-await-trigger! rcvar)))
+       (call-with-values
+           (lambda ()
+             (perform-operation
+              (choice-operation operation expected-blocking-operation)))
+         list)))
+
+;; Now some concurrency tests.
+;;
+;; This test was meant to detect the absence of
+;;   (? (not next-old) (spin next-old)))
+;;
+;; but I didn't ever notice 'spin' being run.
+;; (Try adding a 'pk' before 'spin').
+(test-assert "concurrent ping pong completes"
+  (let^ ((! n/games 400)
+        (! n/rounds 500)
+        (! game/done?
+           (vector-unfold (lambda (_) (make-condition)) n/games))
+        (! start? (make-condition))
+        (! (run-game done?)
+           ;; In each round, concurrently ‘await’
+           ;; and ‘trigger’ the condition.  The result
+           ;; should be that the round eventually
+           ;; is completed.
+           (let^ ((! rcvar (make-repeated-condition))
+                  (/o/ loop (round 0))
+                  (! (next-round) (loop (+ round 1)))
+                  (? (= round n/rounds)
+                     (signal-condition! done?))
+                  (! start-round? (make-condition))
+                  (! awaiter-done? (make-condition))
+                  (! trigger-done? (make-condition))
+                  (<-- ()
+                       (spawn-fiber
+                        (lambda ()
+                          (wait start-round?)
+                          (await-trigger! rcvar)
+                          (signal-condition! awaiter-done?))))
+                  (<-- ()
+                       (spawn-fiber
+                        (lambda ()
+                          (wait start-round?)
+                          (trigger-condition! rcvar)
+                          (signal-condition! trigger-done?))))
+                  (<-- (_) (signal-condition! start-round?))
+                  (<-- () (wait awaiter-done?))
+                  (<-- () (wait trigger-done?)))
+                 (next-round)))
+        (! (spawn-game _ done?)
+           (spawn-fiber
+            (lambda ()
+              (wait start?)
+              (run-game done?)))))
+       (run-fibers
+        (lambda ()
+          (vector-for-each spawn-game game/done?)
+          (signal-condition! start?)
+          (vector-for-each (lambda (_ c) (wait c)) game/done?)
+          #t)
+        #:hz 6000)))
+
+(test-end "repeated condition")

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