From: Rutger van Beusekom <rutger.van.beusekom@verum.com>
Date: Thu, 19 Nov 2020 06:52:16 +0000 (+0100)
Subject: actors: Introduce non-reentrant actors by default.
X-Git-Url: https://jxself.org/git/?a=commitdiff_plain;h=7429578ca2d8511dca2e5ba1b2b79b11a9368f90;p=8sync.git

actors: Introduce non-reentrant actors by default.

* 8sync/actors.scm (actor-reentrant-message-handler): Rename from
actor-inheritable-message-handler.
(actor-non-reentrant-message-handler): New function that queues messages.
(<actor>): Change message-handler to that function and add message-q.
(<reentrant-actor>): New class for the old behaviour.
(initialize): Use the orignal message-handler for this new class.
---

diff --git a/8sync/actors.scm b/8sync/actors.scm
index ceb2980..80d59af 100644
--- a/8sync/actors.scm
+++ b/8sync/actors.scm
@@ -32,6 +32,7 @@
             simple-message-id-generator
 
             <actor>
+	    <reentrant-actor>
             actor-id
             actor-message-handler
 
@@ -293,7 +294,7 @@ raise an exception if an error."
 ;;; Main actor implementation
 ;;; =========================
 
-(define (actor-inheritable-message-handler actor message)
+(define (actor-reentrant-message-handler actor message)
   (define action (message-action message))
   (define method
     (class-rmeta-ref (class-of actor) 'actions action
@@ -307,6 +308,19 @@ raise an exception if an error."
            #:message message))
   (apply method actor message (message-body message)))
 
+(define (actor-non-reentrant-message-handler actor message)
+  (let* ((queue (actor-message-q actor))
+         (messages? (pair? queue)))
+    (warn 'queue-size: (length queue))
+    (set! queue (append queue (list message)))
+    (unless messages?
+      (let loop ()
+        (warn 'handle-message: (message-action message))
+        (actor-reentrant-message-handler actor (car queue))
+        (set! queue (cdr queue))
+        (unless (null? queue)
+          (loop))))))
+
 (define-syntax-rule (build-actions (symbol method) ...)
   "Construct an alist of (symbol . method), where the method is wrapped
 with wrap-apply to facilitate live hacking and allow the method definition
@@ -324,7 +338,7 @@ to come after class definition."
   (hive #:init-keyword #:hive
         #:accessor actor-hive)
   ;; How we receive and process new messages
-  (message-handler #:init-value actor-inheritable-message-handler
+  (message-handler #:init-value actor-non-reentrant-message-handler
                    ;; @@: There's no reason not to use #:class instead of
                    ;;   #:each-subclass anywhere in this file, except for
                    ;;   Guile bug #25211 (#:class is broken in Guile 2.2)
@@ -344,7 +358,15 @@ to come after class definition."
                          (*init* (const #f))
                          ;; Default cleanup method is to do nothing.
                          (*cleanup* (const #f)))
-           #:allocation #:each-subclass))
+           #:allocation #:each-subclass)
+
+  (message-q #:init-value '() #:accessor actor-message-q))
+
+(define-class <reentrant-actor> (<actor>))
+
+(define-method (initialize (o <reentrant-actor>) args)
+  (next-method)
+  (slot-set! o 'message-handler actor-reentrant-message-handler))
 
 ;;; Addresses are vectors where the first part is the actor-id and
 ;;; the second part is the hive-id.  This works well enough... they