[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[gnunet-scheme] branch master updated (a68c0d1 -> 7f6e421)
|
From: |
gnunet |
|
Subject: |
[gnunet-scheme] branch master updated (a68c0d1 -> 7f6e421) |
|
Date: |
Thu, 10 Feb 2022 18:47:51 +0100 |
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 a68c0d1 doc/cadet: Draft documentation on CADET network messages.
new 8dd5ca9 doc: Fix ‘mq-prio-prefs’ cross-reference.
new 3eeafd1 cadet/client: New (stubbed) module.
new 7f6e421 concurrency/lost-and-found: New module.
The 3 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:
Makefile.am | 3 +
doc/service-communication.tm | 11 +-
gnu/gnunet/{dht/network.scm => cadet/client.scm} | 33 ++-
gnu/gnunet/concurrency/lost-and-found.scm | 237 +++++++++++++++++
tests/lost-and-found.scm | 312 +++++++++++++++++++++++
5 files changed, 580 insertions(+), 16 deletions(-)
copy gnu/gnunet/{dht/network.scm => cadet/client.scm} (50%)
create mode 100644 gnu/gnunet/concurrency/lost-and-found.scm
create mode 100644 tests/lost-and-found.scm
diff --git a/Makefile.am b/Makefile.am
index e7ac0f3..b42b6cc 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -47,6 +47,7 @@ modules = \
\
gnu/gnunet/concurrency/update.scm \
gnu/gnunet/concurrency/repeated-condition.scm \
+ gnu/gnunet/concurrency/lost-and-found.scm \
\
gnu/gnunet/mq/envelope.scm \
gnu/gnunet/mq/error-reporting.scm \
@@ -65,6 +66,7 @@ modules = \
\
gnu/gnunet/block.scm \
\
+ gnu/gnunet/cadet/client.scm \
gnu/gnunet/cadet/struct.scm \
\
gnu/gnunet/config/parser.scm \
@@ -193,6 +195,7 @@ SCM_TESTS = \
tests/crypto.scm \
tests/distributed-hash-table.scm \
tests/form.scm \
+ tests/lost-and-found.scm \
tests/netstruct.scm \
tests/time.scm \
tests/tokeniser.scm
diff --git a/doc/service-communication.tm b/doc/service-communication.tm
index c3c36a1..89c187d 100644
--- a/doc/service-communication.tm
+++ b/doc/service-communication.tm
@@ -169,11 +169,12 @@
slice. This is an asynchronuous operation, so this procedure can return
before the service has processed the message.
- Depending on the transport, it might be possible for messages to be lost or
- received out-of-order. Some transports allow to explicitely allow messages
- to be lost or received out-of-order and would by default retransmit lost
- messages and reorder out-of-order messages; this behaviour can to a degree
- be controlled by setting the <dfn|priority-preference> flags.
+ <label|mq-prio-prefs>Depending on the transport, it might be possible for
+ messages to be lost or received out-of-order. Some transports allow to
+ explicitely allow messages to be lost or received out-of-order and would by
+ default retransmit lost messages and reorder out-of-order messages; this
+ behaviour can to a degree be controlled by setting the
+ <dfn|priority-preference> flags.
These flags are not absolute, e.g. even if reliable transmission is
requested, it is possible that the transport fail to transmit the message.
diff --git a/gnu/gnunet/dht/network.scm b/gnu/gnunet/cadet/client.scm
similarity index 50%
copy from gnu/gnunet/dht/network.scm
copy to gnu/gnunet/cadet/client.scm
index 6dd4129..a930f55 100644
--- a/gnu/gnunet/dht/network.scm
+++ b/gnu/gnunet/cadet/client.scm
@@ -1,4 +1,4 @@
-;; This file is part of Scheme-GNUnet
+;; This file is part of Scheme-GNUnet.
;; Copyright © 2022 GNUnet e.V.
;;
;; Scheme-GNUnet is free software: you can redistribute it and/or modify it
@@ -15,13 +15,24 @@
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;
;; SPDX-License-Identifier: AGPL-3.0-or-later
-(define-library (gnu gnunet dht network)
- (export construct-client-get construct-client-put construct-client-result
- analyse-client-get analyse-client-put analyse-client-result)
- (import (rename (gnu gnunet dht client)
- (#{ construct-client-get}# construct-client-get)
- (#{ construct-client-put}# construct-client-put)
- (#{ construct-client-result}# construct-client-result)
- (#{ analyse-client-get}# analyse-client-get)
- (#{ analyse-client-put}# analyse-client-put)
- (#{ analyse-client-result}# analyse-client-result))))
+(define-library (gnu gnunet cadet client)
+ (export connect disconnect!
+ make-cadet-address cadet-address? cadet-address-peer
cadet-address-port
+ channel? open-channel! close-channel!
+ port? open-port! close-port!)
+ (import (only (rnrs base) begin define assert))
+ (begin
+ (define (stub . foo)
+ (error "todo"))
+ (define connect stub)
+ (define disconnect! stub)
+ (define make-cadet-address stub)
+ (define cadet-address? stub)
+ (define cadet-address-peer stub)
+ (define cadet-address-port stub)
+ (define channel? stub)
+ (define open-channel! stub)
+ (define close-channel! stub)
+ (define port? stub)
+ (define open-port! stub)
+ (define close-port! stub)))
diff --git a/gnu/gnunet/concurrency/lost-and-found.scm
b/gnu/gnunet/concurrency/lost-and-found.scm
new file mode 100644
index 0000000..8975240
--- /dev/null
+++ b/gnu/gnunet/concurrency/lost-and-found.scm
@@ -0,0 +1,237 @@
+;; This file is part of Scheme-GNUnet
+;; Copyright © 2022 GNUnet e.V.
+;;
+;; 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: AGPL-3.0-or-later
+
+;; Author: Maxime Devos
+(define-library (gnu gnunet concurrency lost-and-found)
+ (export make-lost-and-found lost-and-found? collect-lost-and-found-operation
+ make-losable <losable> losable?
+ ;; exported for tests
+ (rename (add-found! #{ add-found!}#)))
+ (import (only (rnrs base)
+ begin let define lambda quote if cond eq? assert cons list)
+ (only (rnrs control)
+ when unless)
+ (only (rnrs records syntactic)
+ define-record-type)
+ (only (guile)
+ make-guardian add-hook! after-gc-hook object-address)
+ (only (ice-9 format)
+ format)
+ (only (srfi srfi-9 gnu)
+ set-record-type-printer!)
+ (only (ice-9 atomic)
+ make-atomic-box atomic-box-ref)
+ (only (fibers conditions)
+ make-condition condition? signal-condition! wait-operation)
+ (only (fibers operations)
+ wrap-operation make-base-operation)
+ ;; TODO: move elsewhere
+ (only (gnu gnunet mq envelope)
+ %%bind-atomic-boxen))
+ (begin
+ (define-record-type (<lost-and-found> make-lost-and-found lost-and-found?)
+ ;; Atomic box of [condition | (found found* ...)].
+ ;; When there is nothing found, the condition is unsignalled.
+ ;;
+ ;; To register something lost, it is added to the list (if any),
+ ;; otherwise the condition is replaced by the lost object, then
+ ;; the condition is signalled.
+ (fields (immutable contents-box lost-and-found-contents-box))
+ (protocol (lambda (%make)
+ (lambda ()
+ (%make (make-atomic-box (make-condition)))))))
+
+ (set-record-type-printer!
+ <lost-and-found>
+ (lambda (record port)
+ (format port "#<lost-and-found ~x ~a>"
+ (object-address record)
+ (if (condition?
+ (atomic-box-ref (lost-and-found-contents-box record)))
+ "empty"
+ "non-empty"))))
+
+ ;; TODO: concurrency this operation, not reusable
+ (define (collect-lost-and-found-operation lost-and-found)
+ "Make an operation that will complete when something lost has been
+found and return the newly found objects as a list. If this operation is
+performed multiple times concurrently on the same lost and found, spurious
+wakeups where the empty list is returned are possible."
+ (%%bind-atomic-boxen
+ ((value (lost-and-found-contents-box lost-and-found) swap!))
+ (let ((old value)
+ (new-condition (make-condition)))
+ (define (loop old)
+ ;; The mutation replacing 'old' by 'value' is detected by
+ ;; the tests "new lost between making the operation and performing
+ ;; it".
+ (define new-old (swap! old new-condition))
+ ;; If a condition, a concurrent
+ ;; 'collect-lost-and-found-operation' has took the found
+ ;; objects, return a spurious empty list.
+ ;;
+ ;; The mutations ‘inverse the condition’, ‘remove this clause’,
+ ;; and ‘return new-old’ are detected by the test "concurrent
+ ;; collecting (light)".
+ ;;
+ ;; The mutation ‘replace ‘new-old’ by ‘old’ or ‘value’’ is detected
+ ;; by "new lost between making the operation and performing it (2)".
+ ;;
+ ;; TODO: detect switching the first two clauses.
+ (cond ((condition? new-old) '())
+ ;; eq? and not a condition --> succesfully replaced a
+ ;; list of found objects with 'new-condition', return
+ ;; the list.
+ ;;
+ ;; The mutations ‘remove this clause’, ‘always return the
+ ;; empty list’, ‘inverse the condition’, ‘replace new-old or
+ ;; old by value’ are detected by the test "unreachable + gc ->
+ ;; moved into lost and found".
+ ((eq? old new-old) old)
+ ;; not eq? --> a race happened, retry
+ ;;
+ ;; The mutations ‘removing this clause’,
+ ;; ‘returning the empty list’ and ‘calling loop twice’ are
+ ;; detected by tests "new lost between making the operation and
+ ;; performing it".
+ (#true (loop new-old))))
+ ;; The mutation ‘use value instead of old’ is detected ‘losing and
+ ;; collecting concurrently’ (somewhat irreproducible).
+ (if (condition? old)
+ (wrap-operation
+ ;; The mutation ‘don't wait for anything’ is detected by
+ ;; the test "block while nothing to collect".
+ ;; The mutation ‘use value instead of old’ is detected by
+ ;; the test "losing and collecting concurrently".
+ (wait-operation old)
+ ;; The mutations 'always return the empty list' and 'call loop
+ ;; twice' are detected by test "new lost between making the
+ ;; operation and performing it (2)".
+ ;;
+ ;; The mutation ‘replace old by value’ _survives_ but seems
+ ;; benign.
+ (lambda () (loop old)))
+ ;; 'collect-lost' added something before we started waiting,
+ ;; return it when asked for (unless a race interferes).
+ (make-base-operation
+ #false ; wrap
+ ;; Try (always succeeds).
+ ;; The mutations ‘always return the empty list’ and
+ ;; 'call loop twice' are rejected by test
+ ;; "unreachable + gc -> moved into lost and found".
+ ;;
+ ;; The mutation ‘replace old by value’ _survives_ but seems
+ ;; benign.
+ (lambda () (lambda () (loop old)))
+ ;; There is no block, only try -- try always succeeds.
+ "do not call me, try always returns!")))))
+
+ (define (add-found! lost-and-found lost)
+ "Add an object @var{lost} to @var{lost-and-found}."
+ (%%bind-atomic-boxen
+ ((value (lost-and-found-contents-box lost-and-found) swap!))
+ (let loop ((old value))
+ ;; The mutations ‘simply run the first branch’, ‘simply run
+ ;; the second branch’, ‘run both branches’ and ‘invert the
+ ;; branch condition’ are detected by test "unreachable + gc ->
+ ;; moved into lost and found".
+ ;;
+ ;; TODO: maybe detect replacing ‘old’ by ‘value’.
+ (if (condition? old)
+ ;; Replace the condition by a list containing lost,
+ ;; then notify the condition. This ordering is important,
+ ;; otherwise 'collect-lost-and-found-soperation' could
+ ;; be unnecessarily in the ‘spuriously return the empty list’
+ ;; case, even when there aren't multiple concurrent
+ ;; 'collect-lost-and-found-operation' operations.
+ ;;
+ ;; (Though in practice, this would not seem to be a problem,
+ ;; since 'collect-lost-and-found' is called in a loop anyway.)
+ (let ((new-old (swap! old (list lost))))
+ ;; The mutations ‘invert the branch condition’ and ‘do both
+ ;; branches (in order or out-of-order)’ are detected by the test
+ ;; "unreachable + gc -> moved into lost and found".
+ ;;
+ ;; The mutation ‘simply do the second branch’ is detected by
+ ;; test "new lost between making the operation and performing it
+ ;; (2)" (timeout).
+ ;;
+ ;; The mutation ‘simply do the first branch’ is dected by the
+ ;; test "losing and collecting concurrently" (not 100%
+ ;; reproducible).
+ (if (eq? new-old old)
+ ;; The mutation ‘don't do anything’ is detected by test
+ ;; "new lost between making the operation and performing it
+ ;; (2)" (by timeout).
+ (signal-condition! old)
+ ;; Race was lost, try again!
+ ;;
+ ;; The mutation ‘don't do anything’ is detected by the test
+ ;; "losing and collecting concurrently".
+ ;;
+ ;; The mutation ‘use old instead of new-old’ is detected by
+ ;; the test "losing and collecting concurrently" (infinite
+ ;; loop).
+ ;;
+ ;; The mutation ‘use value instead of new-value’ is
+ ;; _survives_ and seems benign, although possibly suboptimal
+ ;; performance-wise.
+ (loop new-old)))
+ ;; There is already a list of lost objects, extend it.
+ ;; The mutation ‘replace the first old by value’ causes
+ ;; "concurrent losing" to fail. TODO: replacing the second ‘old’
+ ;; is currently undetected.
+ (let ((new-old (swap! old (cons lost old))))
+ ;; The mutations ‘don't do anything’, ‘invert the condition’,
+ ;; ‘replace old by value in the condition’
+ ;; cause the test "concurrent losing" to fail.
+ ;;
+ ;; The mutations ‘always run’ and ‘replace new-old by value in
+ ;; the condition’ cause an infinite loop (presumambly with
+ ;; unbounded memory!). The mutation ‘run loop twice’ seems to
+ ;; cause an OOM or at least very high memory usage.
+ (unless (eq? new-old old)
+ ;; Race was lost, try again!
+ ;;
+ ;; The mutation ‘replace new-old by old’ causes "concurrent
+ ;; losing" to busy hang. The mutation ‘replace new-old by
+ ;; value’ survives and seems benign, although perhaps
+ ;; suboptimal performance-wise.
+ (loop new-old)))))))
+
+ (define *guard* (make-guardian))
+
+ (define-record-type (<losable> make-losable losable?)
+ (fields (immutable lost-and-found losable-lost-and-found))
+ (sealed #false)
+ (protocol (lambda (%make)
+ (lambda (lost-and-found)
+ (assert (lost-and-found? lost-and-found))
+ (let ((object (%make lost-and-found)))
+ (*guard* object)
+ object)))))
+
+ (define (collect-lost)
+ (define object (*guard*))
+ (when object
+ (add-found! (losable-lost-and-found object) object)
+ ;; Absence detected by test
+ ;; "unreachable + gc -> moved into lost and found"
+ (collect-lost)))
+
+ (add-hook! after-gc-hook (lambda () (collect-lost)))))
diff --git a/tests/lost-and-found.scm b/tests/lost-and-found.scm
new file mode 100644
index 0000000..5ff08b2
--- /dev/null
+++ b/tests/lost-and-found.scm
@@ -0,0 +1,312 @@
+;; This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
+;; Copyright © 2022 GNUnet e.V.
+;;
+;; 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: AGPL-3.0-or-later
+
+;; Author: Maxime Devos
+(define-module (test-lost-and-found))
+(import (ice-9 match)
+ (srfi srfi-1)
+ (gnu gnunet concurrency lost-and-found)
+ (rnrs base)
+ (srfi srfi-64)
+ (fibers conditions)
+ (fibers operations)
+ (fibers channels)
+ (rnrs records syntactic)
+ (fibers)
+ (fibers timers)) ; sleep
+
+(test-begin "lost-and-found")
+
+(define-record-type (<losable+datum> make-losable+datum losable+datum?)
+ (parent <losable>)
+ (fields (immutable datum losable-datum))
+ ;; TODO: why is this necessary?
+ (protocol (lambda (%make)
+ (lambda (lost-and-found foo)
+ ((%make lost-and-found) foo)))))
+
+(define (lose lost-and-found start to/exclusive)
+ "Lose integers from the range [start to/exclusive)."
+ (when (< start to/exclusive)
+ (make-losable+datum lost-and-found start)
+ (lose lost-and-found (+ 1 start) to/exclusive)))
+
+(define (collect-operation lost-and-found)
+ "Make an operation returning the list of found integers
+(make sure to gc before performing the operation!)."
+ (wrap-operation
+ (collect-lost-and-found-operation lost-and-found)
+ (lambda (list)
+ (map losable-datum list))))
+
+(define (collect lost-and-found)
+ "Return a list of found integers (make sure to gc first!)."
+ (perform-operation (collect-operation lost-and-found)))
+
+(define (verify collected from to/exclusive)
+ (define count (- to/exclusive from))
+ (define present (make-bitvector count #false))
+ (for-each (lambda (i)
+ (assert (not (bitvector-bit-set? present (- i from))))
+ (bitvector-set-bit! present i))
+ collected)
+ ;; Presumably due to boehmgc being conservative, this number
+ ;; of elements collected tends can be off by one or two.
+ ;; Allow being 5 elements off.
+ (define fraction (/ (bitvector-count present) (- count 5.)))
+ (pk 'f (+ 0.0 fraction))
+ (assert (>= fraction 1))
+ #true
+ #;
+ (receive (collected\expected ∩)
+ (lset-diff+intersection! = collected (iota count from))
+ (assert (null? collected\expected))
+ ;; Presumably due to boehmgc being conservative, this number
+ ;; of elements collected tends can be off by one or two.
+ ;; Allow being 5 elements off.
+ (let ((fraction (/ (length ∩) (- count 5))))
+ (pk 'f (+ 0.0 fraction))
+ (assert (>= fraction 1))
+ #true)))
+
+(define %count 1000)
+(test-assert "unreachable + gc -> moved into lost and found"
+ (let ((lost-and-found (make-lost-and-found)))
+ (lose lost-and-found 0 %count)
+ (gc)
+ (verify (collect lost-and-found) 0 %count)))
+
+(test-assert "new lost between making the operation and performing it (1)"
+ (let ((lost-and-found (make-lost-and-found)))
+ (lose lost-and-found 0 %count)
+ (gc)
+ (define operation (collect-operation lost-and-found))
+ (lose lost-and-found %count (* 2 %count))
+ (gc)
+ (verify (perform-operation operation) 0 (* 2 %count))))
+
+(test-assert "new lost between making the operation and performing it (2)"
+ (let ((lost-and-found (make-lost-and-found)))
+ (lose lost-and-found 0 %count)
+ ;; <- no gc!
+ (define operation (collect-operation lost-and-found))
+ (lose lost-and-found %count (* 2 %count))
+ (gc)
+ (verify (perform-operation operation) 0 (* 2 %count))))
+
+(test-assert "concurrent collecting (light)"
+ (let ((lost-and-found (make-lost-and-found)))
+ (lose lost-and-found 0 %count)
+ (gc)
+ (define operation1 (collect-operation lost-and-found))
+ (define operation2 (collect-operation lost-and-found))
+ (define result1 (perform-operation operation1))
+ ;; Technically, this is allowed to hang (since everything is
+ ;; collected by result1), but due to implementation details,
+ ;; it doesn't.
+ (define result2 (perform-operation operation2))
+ (verify result1 0 %count)
+ (verify (append result1 result2) 0 %count)))
+
+
+;; TODO: copied from (tests update)
+;; TODO: 1e-4 is not sufficient here, 1e-3 is required to make tests
+;; fail (CPU-dependent?).
+(define expected-blocking-operation
+ (wrap-operation (sleep-operation 1e-3) (lambda () 'blocking)))
+
+(test-eq "block while nothing to collect"
+ 'blocking
+ (perform-operation
+ (choice-operation (collect-operation (make-lost-and-found))
+ expected-blocking-operation)))
+
+(test-assert "delaying performing the operation, some concurrency"
+ (let* ((lost-and-found (make-lost-and-found))
+ ;; 'lost-and-found' currently has a condition, so the
+ ;; (if (condition? old) ...) case should happen here
+ (operation (collect-operation lost-and-found)))
+ ;; Trigger and replace the original condition.
+ (lose lost-and-found 0 %count)
+ (gc)
+ (collect lost-and-found)
+ ;; Run the original operation.
+ (define result
+ (perform-operation
+ (choice-operation operation expected-blocking-operation)))
+ ;; The lost objects were already collected, so blocking is fine.
+ ;; There's a form of concurrency, so a spurious empty list is
+ ;; also allowed.
+ (memq result '(blocking ()))))
+
+(define add-found! #{ add-found!}#)
+
+;; There is no rule against the GC hook being called from within the GC hook,
+;; or the GC hook being called in parallel from another thread running the
+;; GC hook, in case a lot of garbage was generated before the original
+;; invocation of the GC hook was able to finish.
+;;
+;; This seems a bit difficult to reliably trigger, so cheat by manually adding
+;; running 'add-found!' concurrently.
+
+(define (lose* lost-and-found start to/exclusive)
+ "Lose integers from the range [start to/exclusive), bypassing the GC and not
+wrap things in a <losable+datum>."
+ (when (< start to/exclusive)
+ (add-found! lost-and-found start)
+ (lose* lost-and-found (+ 1 start) to/exclusive)))
+
+(define (collect* lost-and-found)
+ "Return a list of found integers (no need to GC, since the GC and guardian
was
+bypassed by calling @code{add-found!} directly)."
+ (perform-operation (collect-lost-and-found-operation lost-and-found)))
+
+;; In the current implementation of Guile, while to a degree GC is
parellelised,
+;; gc hooks are serialised (or maybe not, since ‘this hook is run
+(test-assert "concurrent losing"
+ (run-fibers
+ (lambda ()
+ (define %count/fiber 100000)
+ (define fibers 8)
+ (define start (make-condition))
+ (define done-channel (make-channel))
+ (define lost-and-found (make-lost-and-found))
+ (define (lose/async from to/exclusive)
+ (spawn-fiber
+ (lambda ()
+ (wait start)
+ (lose* lost-and-found from to/exclusive)
+ (put-message done-channel 'done))))
+ (let loop ((i 0))
+ (when (< i fibers)
+ (lose/async (* i %count/fiber) (* (+ 1 i) %count/fiber))
+ (loop (+ i 1))))
+ (signal-condition! start)
+ (let loop ((i 0))
+ (when (< i fibers)
+ (get-message done-channel)
+ (loop (+ i 1))))
+ (verify (collect* lost-and-found) 0 (* %count/fiber fibers)))
+ #:install-suspendable-ports? #false ; unnecessary
+ #:hz 10000))
+
+(test-assert "losing and collecting concurrently"
+ (run-fibers
+ (lambda ()
+ ;; 100000 does not suffice for testing the first
+ ;; '(loop new-old)' in 'add-found!'.
+ (define %count/loser 1000000)
+ (define %losers 8)
+ (define %collectors 8)
+ (define start (make-condition))
+ (define done-losing (make-condition))
+ (define done-channel/losers (make-channel))
+ (define done-channel/collectors (make-channel))
+ (define done-losing-operation
+ (wrap-operation
+ (wait-operation done-losing)
+ (lambda () 'done)))
+ (define lost-and-found (make-lost-and-found))
+ (define (lose/async from to/exclusive)
+ (spawn-fiber
+ (lambda ()
+ (wait start)
+ (lose* lost-and-found from to/exclusive)
+ (put-message done-channel/losers 'done))))
+ ;; vector of list of list of collected objects
+ (define collected (make-vector %collectors))
+ (define (collect/async i)
+ (spawn-fiber
+ (lambda ()
+ (wait start)
+ (let loop ((list-of-list-of-results '()))
+ (define r
+ (perform-operation
+ (choice-operation
+ (collect-lost-and-found-operation lost-and-found)
+ done-losing-operation)))
+ (if (eq? r 'done)
+ (begin
+ (vector-set! collected i list-of-list-of-results)
+ (put-message done-channel/collectors 'done))
+ (loop (cons r list-of-list-of-results)))))))
+ ;; Start fibers collecting integers.
+ (let loop ((i 0))
+ (when (< i %collectors)
+ (collect/async i)
+ (loop (+ i 1))))
+ ;; Start fibers losing integers
+ (let loop ((i 0))
+ (when (< i %losers)
+ (lose/async (* i %count/loser) (* (+ 1 i) %count/loser))
+ (loop (+ i 1))))
+ ;; Try starting the collectors and losers start at the same time, to
+ ;; maximise concurrency.
+ (signal-condition! start)
+ (let loop ((i 0))
+ (when (< i %losers)
+ (get-message done-channel/losers)
+ (loop (+ i 1))))
+ (signal-condition! done-losing)
+ ;; Wait for 'collected' to be initialised.
+ (let loop ((i 0))
+ (when (< i %collectors)
+ (get-message done-channel/collectors)
+ (loop (+ i 1))))
+ ;; Do like 'verify' does, without the - 5 because the GC
+ ;; was bypassed.
+ (define results (make-bitvector (* %count/loser %losers)))
+ (define (register-result! i)
+ (assert (not (bitvector-bit-set? results i)))
+ (bitvector-set-bit! results i))
+ (let loop ((i 0))
+ (when (< i %collectors)
+ (for-each
+ (lambda (list)
+ (for-each register-result! list))
+ (vector-ref collected i))
+ (loop (+ i 1))))
+ (define fraction (/ (bitvector-count results) (bitvector-length results)))
+ (pk 'f (+ 0.0 fraction))
+ (assert (>= fraction 1)))
+ #:install-suspendable-ports? #false ; unnecessary
+ #:hz 10000))
+
+(test-assert "lost-and-found as a string (empty)"
+ (let* ((l (make-lost-and-found))
+ (expected (format #f "#<lost-and-found ~x empty>"
+ (object-address l)))
+ (found (object->string l)))
+ (string=? expected found)))
+
+;; It is important to _not_ print the objects inside the lost-and-found,
+;; because <losable> objects keep a lost-and-found in their fields and hence
+;; printing these objects would lead to infinite recursion.
+(test-assert "lost-and-found as a string (non-empty)"
+ (let* ((l (make-lost-and-found))
+ (expected (format #f "#<lost-and-found ~x non-empty>"
+ (object-address l))))
+ (add-found! l (make-losable l))
+ (define found (object->string l))
+ (string=? expected found)))
+
+;; The exception is better raised during the construction of the
+;; <losable> than during the after-gc hook.
+(test-error "make-losable without lost-and-found" (make-losable 'bogus))
+
+(test-end "lost-and-found")
--
To stop receiving notification emails like this one, please contact
gnunet@gnunet.org.
- [gnunet-scheme] branch master updated (a68c0d1 -> 7f6e421),
gnunet <=