From edb8e719f7a1ef7ed1d0ae5116df6fa36df07b05 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Fri, 27 Apr 2018 17:30:26 +0100 Subject: [PATCH] More robust approach to cleanup of assertions on actor termination. We now explicitly track *committed* assertions of each actor in a new field, `actor-cleanup-changes`. Each time a patch action is *performed*, `actor-cleanup-changes` is updated. When an actor quits, it enqueues a special new kind of action, a `quit` action. When a `quit` action is performed, any remaining contents of `actor-cleanup-changes` are processed in order to fully remove any leftover assertions. (Leftover assertions will only arise in exceptional cases: when some stop-script or facet boot-script raises an uncaught exception.) As part of this commit, we undo the effect of commit 8624047. --- syndicate/bag.rkt | 8 +++---- syndicate/dataspace.rkt | 53 +++++++++++++++++++++++++++-------------- 2 files changed, 39 insertions(+), 22 deletions(-) diff --git a/syndicate/bag.rkt b/syndicate/bag.rkt index 4e4aca8..9dc230e 100644 --- a/syndicate/bag.rkt +++ b/syndicate/bag.rkt @@ -19,8 +19,8 @@ ;; ;; A `(Bagof X)` is similar, but immutable. ;; -;; A `(Deltaof X)` is a `(MutableHash X Int)`, just like a -;; `(MutableBagof X)` except the replication counts can be negative. +;; `MutableDeltaof` and `Deltaof` are like `MutableBagof` and `Bagof`, +;; respectively, except the replication counts can be negative. (define make-bag make-hash) (define bag hash) @@ -52,6 +52,6 @@ (define-syntax-rule (in-bag piece ...) (in-hash-keys piece ...)) (define-syntax-rule (in-bag/count piece ...) (in-hash piece ...)) -(define (set->bag s) +(define (set->bag s [count 1]) (for/hash [(e (in-set s))] - (values e 1))) + (values e count))) diff --git a/syndicate/dataspace.rkt b/syndicate/dataspace.rkt index 4477dac..5f9e272 100644 --- a/syndicate/dataspace.rkt +++ b/syndicate/dataspace.rkt @@ -71,11 +71,15 @@ ;; A `Dataspace` is a ... TODO -;; An `Action` is either `(patch (Deltaof Assertion))` or `(message -;; Assertion)` or `(spawn Any BootProc (Set Assertion))`. +;; An `Action` is one of +;; - `(patch (MutableDeltaof Assertion))` +;; - `(message Assertion)` +;; - `(spawn Any BootProc (Set Assertion))` +;; - `(quit)`. (struct patch (changes) #:prefab) (struct message (body) #:prefab) (struct spawn (name boot-proc initial-assertions) #:prefab) +(struct quit () #:prefab) (struct dataspace ([next-id #:mutable] ;; Nat routing-table ;; Skeleton @@ -95,6 +99,7 @@ pending-scripts ;; (MutableVectorof (Queueof (-> Any))) [pending-actions #:mutable] ;; (Queueof Action) [adhoc-assertions #:mutable] ;; (Bagof Assertion) + [cleanup-changes #:mutable] ;; (Deltaof Assertion) ) #:methods gen:custom-write [(define (write-proc a p mode) @@ -230,7 +235,8 @@ #f (make-vector priority-count (make-queue)) (make-queue) - (set->bag filtered-initial-assertions))) + (set->bag filtered-initial-assertions +1) + (set->bag filtered-initial-assertions -1))) (for [(a filtered-initial-assertions)] (match (bag-change! (dataspace-assertions ds) a +1) ['absent->present (add-assertion! (dataspace-routing-table ds) a)] @@ -333,16 +339,27 @@ ;; (log-info "~a performing ~a" ac action) (match action [(patch delta) - (for [((a count) (in-bag/count delta))] - (match (bag-change! (dataspace-assertions ds) a count) - ['present->absent (remove-assertion! (dataspace-routing-table ds) a)] - ['absent->present (add-assertion! (dataspace-routing-table ds) a)] - ;; 'absent->absent absurd - ['present->present (void)]))] ;; i.e. no visible change + (apply-patch! ds ac delta)] [(message body) (send-assertion! (dataspace-routing-table ds) body)] [(spawn name boot-proc initial-assertions) - (add-actor! ds name boot-proc initial-assertions)])))) + (add-actor! ds name boot-proc initial-assertions)] + [(quit) + (apply-patch! ds ac (actor-cleanup-changes ac))])))) + +(define (apply-patch! ds ac delta) + (define ds-assertions (dataspace-assertions ds)) + (define rt (dataspace-routing-table ds)) + (define new-cleanup-changes + (for/fold [(cleanup-changes (actor-cleanup-changes ac))] [((a count) (in-bag/count delta))] + (match (bag-change! ds-assertions a count) + ['present->absent (remove-assertion! rt a)] + ['absent->present (add-assertion! rt a)] + ;; 'absent->absent absurd + ['present->present (void)]) ;; i.e. no visible change + (define-values (updated-bag _summary) (bag-change cleanup-changes a (- count))) + updated-bag)) + (set-actor-cleanup-changes! ac new-cleanup-changes)) (define (run-scripts! ds) (run-all-pending-scripts! ds) @@ -421,13 +438,17 @@ (let abort-facet! ((f f)) (set-facet-live?! f #f) (for [(child (in-set (facet-children f)))] (abort-facet! child)) - (retract-facet-assertions-and-subscriptions! ds f))))) + (retract-facet-assertions-and-subscriptions! ds f)))) + (push-script! ds the-actor (lambda () (enqueue-action! the-actor (quit))))) ;; Cleanly terminates a facet and its children, running stop-scripts etc. (define (terminate-facet! ds f) (when (facet-live? f) (define ac (facet-actor f)) (define parent (facet-parent f)) + (if parent + (set-facet-children! parent (set-remove (facet-children parent) f)) + (set-actor-root-facet! ac #f)) (set-facet-live?! f #f) @@ -444,13 +465,9 @@ (push-script! #:priority *gc-priority* ds ac (lambda () - (cond - [parent - (set-facet-children! parent (set-remove (facet-children parent) f)) - (when (facet-inert? ds parent) (terminate-facet! ds parent))] - [else - (set-actor-root-facet! ac #f) - (terminate-actor! ds ac)]))))) + (if parent + (when (facet-inert? ds parent) (terminate-facet! ds parent)) + (terminate-actor! ds ac)))))) (define (stop-facet! ds f stop-script) (define ac (facet-actor f))