From a247d8fd2b058cf87988d27c2ffce4a32ed91d9e Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Fri, 27 Apr 2018 09:59:03 +0100 Subject: [PATCH] Switch adhoc-assertions to a bag (from a set). This repairs a bug regarding crashes in a new actor's boot-proc. Previously, if boot-proc raised an exception, the initial assertions would stick around forever. By changing adhoc-assertions to a bag rather than a set, and putting the initial assertions in the bag, we put them somewhere they are guaranteed to be processed during actor termination, even when an exception is signalled during boot. This is an API change wrt the previous Syndicate implementation: assert!/retract! now have bag semantics, not set semantics. We can add set-semantics APIs if we end up needing them, of course, layered on top of the bag implementation. --- syndicate/dataspace.rkt | 39 ++++++++++++++++++++++++--------------- syndicate/syntax.rkt | 23 ++++++++++++++++++++++- 2 files changed, 46 insertions(+), 16 deletions(-) diff --git a/syndicate/dataspace.rkt b/syndicate/dataspace.rkt index 98b242a..584ed60 100644 --- a/syndicate/dataspace.rkt +++ b/syndicate/dataspace.rkt @@ -82,7 +82,7 @@ ;; v TODO: Caches have to be bags, not sets; once ;; this change is made, can I avoid keeping a bag ;; of assertions in the dataspace as a whole? - assertions ;; (Bagof Assertion) + assertions ;; (MutableBagof Assertion) dataflow ;; DataflowGraph [runnable #:mutable] ;; (Listof Actor) [pending-actions #:mutable] ;; (Queueof ActionGroup) @@ -94,8 +94,7 @@ [runnable? #:mutable] ;; Boolean pending-scripts ;; (MutableVectorof (Queueof (-> Any))) [pending-actions #:mutable] ;; (Queueof Action) - ;; TODO: consider using a bag, rather than set, of ad-hoc assertions. - [adhoc-assertions #:mutable] ;; (Setof Assertion) + [adhoc-assertions #:mutable] ;; (Bagof Assertion) ) #:methods gen:custom-write [(define (write-proc a p mode) @@ -224,14 +223,15 @@ (define (add-actor! ds name boot-proc initial-assertions) (define the-actor-id (generate-id! ds)) + (define filtered-initial-assertions (set-remove initial-assertions (void))) (define the-actor (actor the-actor-id name #f #f (make-vector priority-count (make-queue)) (make-queue) - (set))) - (for [(a initial-assertions)] + (set->bag filtered-initial-assertions))) + (for [(a filtered-initial-assertions)] (match (bag-change! (dataspace-assertions ds) a 1) ['absent->present (add-assertion! (dataspace-routing-table ds) a)] ;; 'absent->absent and 'present->absent absurd @@ -242,7 +242,8 @@ #f (lambda () (boot-proc) - (for [(a initial-assertions)] (retract! the-actor a))))) + (for [(a filtered-initial-assertions)] + (adhoc-retract! the-actor a))))) (define-syntax-rule (with-current-facet [ds0 a0 f0 script?] body ...) (let ((ds ds0) @@ -413,7 +414,7 @@ ;; Abruptly terminates an entire actor, without running stop-scripts etc. (define (terminate-actor! ds the-actor) (push-script! ds the-actor - (lambda () (for [(a (in-set (actor-adhoc-assertions the-actor)))] + (lambda () (for [(a (in-bag (actor-adhoc-assertions the-actor)))] (retract! the-actor a)))) (let ((f (actor-root-facet the-actor))) (when f @@ -495,16 +496,24 @@ (bag-change! (ensure-patch-action! ac) assertion +1))) (define (adhoc-retract! ac assertion) - (define adhoc-assertions (actor-adhoc-assertions ac)) - (when (and (not (void? assertion)) (set-member? adhoc-assertions assertion)) - (set-actor-adhoc-assertions! ac (set-remove adhoc-assertions assertion)) - (retract! ac assertion))) + (when (not (void? assertion)) + (define-values (new-assertions summary) (bag-change (actor-adhoc-assertions ac) assertion -1)) + (set-actor-adhoc-assertions! ac new-assertions) + (match summary + ;; 'absent->absent and 'absent->present absurd (if the call to + ;; `adhoc-retract!` matches a previous `adhoc-assert!`) + ['present->absent (retract! ac assertion)] + ['present->present (void)]))) (define (adhoc-assert! ac assertion) - (define adhoc-assertions (actor-adhoc-assertions ac)) - (when (and (not (void? assertion)) (not (set-member? adhoc-assertions assertion))) - (set-actor-adhoc-assertions! ac (set-add adhoc-assertions assertion)) - (assert! ac assertion))) + (when (not (void? assertion)) + (define-values (new-assertions summary) (bag-change (actor-adhoc-assertions ac) assertion +1)) + (set-actor-adhoc-assertions! ac new-assertions) + (match summary + ;; 'absent->absent and 'present->absent absurd (assuming there + ;; haven't been too many calls to `adhoc-retract!` in the past) + ['absent->present (assert! ac assertion)] + ['present->present (void)]))) (define (dataspace-unsubscribe! ds h) (remove-interest! (dataspace-routing-table ds) h)) diff --git a/syndicate/syntax.rkt b/syndicate/syntax.rkt index 3da4f40..57292ed 100644 --- a/syndicate/syntax.rkt +++ b/syndicate/syntax.rkt @@ -616,6 +616,26 @@ ;; stop script), we will never retract an assertion more or ;; fewer than the correct number of times. + ;; Expected output: + ;; + ;; marker appeared + ;; marker disappeared + ;; + ;; (plus the exception report for "Deliberate error") + + (spawn #:assertions ['marker] + (error 'test-case "Deliberate error") + (void)) + + (spawn (on (asserted 'marker) (printf "marker appeared\n")) + (on (retracted 'marker) (printf "marker disappeared\n"))) + ) + + #;(lambda () + ;; Goal: no matter the circumstances (e.g. exception in a + ;; stop script), we will never retract an assertion more or + ;; fewer than the correct number of times. + ;; Test cleanup after exception in stop script ;; ;; Correct output: @@ -739,7 +759,8 @@ (retract! (entry 'c 33)) (assert! (entry 'a 9)) (pause) - (for [(a (current-adhoc-assertions))] + (local-require "bag.rkt") + (for [(a (in-bag (current-adhoc-assertions)))] (local-require racket/match) (match a [(entry 'a _) (retract! a)]