[gnunet-scheme] 04/42: dht/client: Eliminate mutation from the control loop.

[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 b2039a8c4fccb4e5d98c2859c40f89ed58efe739
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Thu Sep 8 19:51:02 2022 +0200

    dht/client: Eliminate mutation from the control loop.
    
    The first try at converting the control loop to (gnu gnunet server)
    didn't work out, hopefully bringing it closer to the actor model
    (removing some state) will help.
    
    * gnu/gnunet/dht/client.scm (control): Replace hash tables with
    'bbtrees' from pfds.
    (empty-bbtree): New variable.
---
 gnu/gnunet/dht/client.scm | 137 ++++++++++++++++++++++++++--------------------
 1 file changed, 78 insertions(+), 59 deletions(-)

diff --git a/gnu/gnunet/dht/client.scm b/gnu/gnunet/dht/client.scm
index d5e95a7..a58a473 100644
--- a/gnu/gnunet/dht/client.scm
+++ b/gnu/gnunet/dht/client.scm
@@ -86,15 +86,16 @@
                make-disconnect! handle-control-message!)
          (only (guile)
                pk define-syntax-rule define* lambda* error
-               make-hash-table hashq-set! hashq-remove! hashv-set! hashv-ref
-               hashv-remove! hash-clear! hash-map->list
                ->bool and=>)
          (only (ice-9 atomic)
-               make-atomic-box atomic-box-ref atomic-box-set!)
+               make-atomic-box)
          (only (ice-9 match)
                match)
          (only (ice-9 weak-vector)
                weak-vector weak-vector-ref weak-vector?)
+         (only (pfds bbtrees)
+               bbtree-size bbtree-fold bbtree-set bbtree-contains?
+               bbtree-delete make-bbtree bbtree-ref)
          (only (gnu extractor enum)
                symbol-value)
          (only (fibers)
@@ -121,7 +122,7 @@
          (only (gnu gnunet utils cut-syntax)
                cut-syntax)
          (only (rnrs base)
-               and >= = quote * / + - define begin ... let*
+               and < >= = quote * / + - define begin ... let*
                quote case else values apply let cond if > eq?
                <= expt assert exact? integer? lambda for-each
                not expt min max div-and-mod positive? define-syntax
@@ -133,7 +134,9 @@
          (only (rnrs conditions)
                &error condition make-who-condition define-condition-type)
          (only (rnrs exceptions)
-               raise))
+               raise)
+         (only (srfi srfi-26)
+               cut))
   (begin
     ;; The minimal and maximal replication levels the DHT service allows.
     ;; While the service won't reject replication levels outside this range,
@@ -745,7 +748,7 @@ when the connection has been made.  The connection can 
break; the optional thunk
 @var{disconnected} is called when it does. If the connection breaks, the client
 code automatically tries to reconnect, so @var{connected} can be called after
 @var{disconnected}.  This procedure returns a DHT server object."
-      (define old-id->operation-map (make-hash-table))
+      (define old-id->operation-map empty-bbtree)
       (define server (make-server))
       ;; We could do @code{(spawn (lambda () (reconnect ...)))} here instead,
       ;; but that causes ‘(DHT) garbage collectable’ to fail.
@@ -774,8 +777,6 @@ code automatically tries to reconnect, so @var{connected} 
can be called after
        "Ask @code{control} what is the iterator for the get operation with
 unique id @var{unique-id}.  If there is no such get operation, or the get
 operation is cancelled, return @code{#false} instead."
-       ;; It is possible to look at id->operation-map directly instead,
-       ;; but hash tables are thread-unsafe.
        ;; TODO: is the 'terminal-condition' case needed?
        (maybe-ask* terminal-condition control-channel
                    'request-search-result-iterator
@@ -834,6 +835,8 @@ operation is cancelled, return @code{#false} instead."
               ;; TODO: wrong type (maybe a put handle?).
               TODO-error-reporting/2)))))
 
+    (define empty-bbtree (make-bbtree <))
+
     (define* (reconnect terminal-condition config
                        old-id->operation-map control-channel lost-and-found
                        #:key (spawn spawn-fiber)
@@ -857,7 +860,6 @@ operation is cancelled, return @code{#false} instead."
       ;;
       ;; This code is written to support both the correct and incorrect 
behaviour
       ;; of guardians+weak vectors.
-      (define id->operation-map (make-hash-table))
       (define handlers (apply make-message-handlers
                              #:terminal-condition terminal-condition
                              #:control-channel control-channel rest))
@@ -866,16 +868,22 @@ operation is cancelled, return @code{#false} instead."
                            control-channel))
       (define mq (connect/fibers config "dht" handlers error-handler
                                 #:spawn spawn))
-      (define (process-stop-search get)
+      (define (process-stop-search old-id->operation-map id->operation-map get)
        ;; TODO: tests!
        ;; TODO: cancel outstanding messages to the DHT services for this
        ;; get operation (including the request to start searching), if
        ;; any.
-       (hashv-remove! old-id->operation-map (get:unique-id get))
-       (when (hashv-ref id->operation-map (get:unique-id get))
-         (hashv-remove! id->operation-map (get:unique-id get))
-         (send-stop-get! mq get)))
-      (define (k/reconnect!)
+       (let^ ((! old-id->operation-map
+                 (bbtree-delete old-id->operation-map (get:unique-id get)))
+              (? (not (bbtree-contains? id->operation-map (get:unique-id get)))
+                 (values old-id->operation-map id->operation-map))
+              (! id->operation-map
+                 (bbtree-delete id->operation-map (get:unique-id get))))
+             (send-stop-get! mq get)
+             (values old-id->operation-map id->operation-map)))
+      (define (k/reconnect! old-id->operation-map id->operation-map)
+       ;; Self-check to make sure no information will be lost.
+       (assert (= (bbtree-size old-id->operation-map) 0))
        (apply reconnect terminal-condition config id->operation-map
               control-channel lost-and-found rest))
       (define loop-operation
@@ -883,74 +891,85 @@ operation is cancelled, return @code{#false} instead."
         (get-operation control-channel)
         (wrap-operation (collect-lost-and-found-operation lost-and-found)
                         (lambda (lost) (cons 'lost lost)))))
-      (define (control)
+      (define (control old-id->operation-map id->operation-map)
        "The main event loop."
-       (control* (perform-operation loop-operation)))
-      (define (control* message)
+       (control* old-id->operation-map id->operation-map
+                 (perform-operation loop-operation)))
+      (define (control* old-id->operation-map id->operation-map message)
+       (define (continue/no-change)
+         (control old-id->operation-map id->operation-map))
        (match message
          (('start-get! get)
           ;; Register the new get operation, such that we remember
           ;; where to send responses to.
-          (hashv-set! id->operation-map (get:unique-id get)
-                      ((if (get:linger? get)
-                          make-strong-reference
-                          make-weak-reference) get))
-          ;; (Asynchronuously) send the GET message.
-          (send-get! mq get)
-          ;; Continue!
-          (control))
+          (let ((id->operation-map
+                 (bbtree-set id->operation-map
+                             (get:unique-id get)
+                             ((if (get:linger? get)
+                                  make-strong-reference
+                                  make-weak-reference) get))))
+            ;; (Asynchronuously) send the GET message.
+            (send-get! mq get)
+            ;; Continue!
+            (control old-id->operation-map id->operation-map)))
          (('stop-search! get)
-          (process-stop-search get)
-          ;; Continue!
-          (control))
+          (let^ ((<-- (old-id->operation-map id->operation-map)
+                      (process-stop-search
+                       old-id->operation-map id->operation-map get)))
+            (control old-id->operation-map id->operation-map)))
          (('put! put)
           ;; Send the put operation to the DHT service.
           (send-message! mq (put:message put))
-          ;; Continue!
-          (control))
+          (continue/no-change))
          ;; Send by @code{request-search-result-iterator}.
          (('request-search-result-iterator answer-box unique-id)
           (answer answer-box
-                  (and=> (hashv-ref id->operation-map unique-id)
+                  (and=> (bbtree-ref id->operation-map unique-id)
                          dereference))
-          ;; Continue!
-          (control))
+          (continue/no-change))
          (('resend-old-operations!)
           ;; Restart old operations.  Only get operations need to be submitted
           ;; again.
           ;;
           ;; TODO: restarting monitoring operations
-          (for-each (lambda (reference)
-                      (define get (dereference reference))
-                      ;; If the (weak) reference is broken, that means the
-                      ;; operation is unreachable, so then there is no point
-                      ;; to resending the get operation.
-                      (when get
-                        (hashv-set! id->operation-map (get:unique-id get)
-                                    reference)
-                        (send-get! mq get)))
-                    ;; XXX: @code{hash-for-each} forms a continuation barrier,
-                    ;; so turn the hash table into a list before iterating.
-                    (hash-map->list (lambda (x reference) reference)
-                                    old-id->operation-map))
-          ;; Free some memory.
-          (hash-clear! old-id->operation-map)
-          ;; Continue!
-          (control))
+          (let ((id->operation-map
+                 (bbtree-fold
+                  (lambda (id reference id->operation-map)
+                    (let^ ((! get (dereference reference))
+                           ;; If the (weak) reference is broken, that means
+                           ;; the operation is unreachable, so then there is
+                           ;; no point to resending the get operation.
+                           (? (not get)
+                              id->operation-map)
+                           (! id->operation-map
+                              (bbtree-set id->operation-map id reference)))
+                          (send-get! mq get)
+                          id->operation-map))
+                  id->operation-map
+                  old-id->operation-map))
+                ;; Free some memory.
+                (old-id->operation-map empty-bbtree))
+            (control old-id->operation-map id->operation-map)))
          ;; Some handles became unreachable and can be cancelled.
          (('lost . lost)
-          (let loop ((lost lost))
+          (let loop ((lost lost) (old-id->operation-map old-id->operation-map)
+                     (id->operation-map id->operation-map))
             (match lost
               ;; Continue!
-              (() (control))
+              (() (control old-id->operation-map id->operation-map))
               ((object . rest)
                (match object
-                 ((? get? get)
-                  (process-stop-search get)
-                  (loop rest))
+                 ((? get? get)
+                  (let^ ((<-- (old-id->operation-map id->operation-map)
+                              (process-stop-search old-id->operation-map
+                                                   id->operation-map
+                                                   get)))
+                        (loop rest old-id->operation-map id->operation-map)))
                  ((? server:dht? server)
-                  (control* '(disconnect!))))))))
+                  (control* old-id->operation-map id->operation-map
+                            '(disconnect!))))))))
          (rest (handle-control-message!
-                rest mq terminal-condition k/reconnect!))))
+                rest mq terminal-condition
+                (cut k/reconnect! old-id->operation-map id->operation-map)))))
       ;; Start the main event loop.
-      (control))))
+      (control old-id->operation-map empty-bbtree))))

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