diff --git a/imperative/dataspace.rkt b/imperative/dataspace.rkt index ce6ccf1..d71daf7 100644 --- a/imperative/dataspace.rkt +++ b/imperative/dataspace.rkt @@ -361,15 +361,15 @@ (push-script! ac k)]) (run-all-pending-scripts! ds)))) -(define (apply-patch! ds ac delta [restriction-path #f]) +(define (apply-patch! ds ac delta) (when (not (bag-empty? 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 (cons a restriction-path) count) - ['present->absent (remove-assertion! rt a restriction-path)] - ['absent->present (add-assertion! rt a restriction-path)] + (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))) diff --git a/imperative/relay.rkt b/imperative/relay.rkt index d645c36..03bfbb0 100644 --- a/imperative/relay.rkt +++ b/imperative/relay.rkt @@ -84,17 +84,16 @@ outer-capture-proj (lambda (op . captured-values) (define term (inbound (instantiate-term->value x captured-values))) + (define assertion (visibility-restriction inner-capture-proj term)) ;; (log-info "~a => ~a ~a ~v" ;; outer-facet ;; inner-facet ;; op - ;; term) + ;; assertion) (match op - ['+ (apply-patch! inner-ds inner-actor (bag term +1) inner-capture-proj)] - ['- (apply-patch! inner-ds inner-actor (bag term -1) inner-capture-proj)] - ['! (send-assertion! (dataspace-routing-table inner-ds) - term - inner-capture-proj)]) + ['+ (apply-patch! inner-ds inner-actor (bag assertion +1))] + ['- (apply-patch! inner-ds inner-actor (bag assertion -1))] + ['! (send-assertion! (dataspace-routing-table inner-ds) assertion)]) (schedule-inner!)) (lambda (cache) (apply-patch! @@ -102,8 +101,10 @@ inner-actor (for/bag/count [(captured-values (in-bag cache))] ;; (log-info "~a (cleanup) ~v" inner-actor term) - (values (inbound (instantiate-term->value x captured-values)) -1)) - inner-capture-proj) + (values (visibility-restriction + inner-capture-proj + (inbound (instantiate-term->value x captured-values))) + -1))) (schedule-inner!)))) (add-endpoint-if-live! outer-facet inbound-endpoints diff --git a/imperative/skeleton.rkt b/imperative/skeleton.rkt index b56fad3..2c988a4 100644 --- a/imperative/skeleton.rkt +++ b/imperative/skeleton.rkt @@ -3,14 +3,13 @@ ;; In particular, they efficiently connect assertions to matching interests. (provide (struct-out skeleton-interest) + (struct-out visibility-restriction) make-empty-skeleton add-interest! remove-interest! add-assertion! remove-assertion! - send-assertion! - apply-projection - apply-projection-path) + send-assertion!) (require syndicate/support/struct) (require racket/match) @@ -23,6 +22,13 @@ (module+ test (require rackunit)) +;; A VisibilityRestriction describes ... TODO +;; (visibility-restriction SkProj Assertion) +(struct visibility-restriction (path term) #:transparent) + +;; A ScopedAssertion is a VisibilityRestriction or an Assertion. +;; (Corollary: Instances of `visibility-restriction` can never be assertions.) + ;; A `Skeleton` is a structural guard on an assertion: essentially, ;; specification of (the outline of) its shape; its silhouette. ;; Following a skeleton's structure leads to zero or more `SkCont`s. @@ -48,10 +54,10 @@ ;; containing the structures. ;; ;; SkCont = (skeleton-continuation -;; (MutableSet Assertion) +;; (MutableSet ScopedAssertion) ;; (MutableHash SkProj (MutableHash SkKey SkConst))) ;; SkConst = (skeleton-matched-constant -;; (MutableSet Assertion) +;; (MutableSet ScopedAssertion) ;; (MutableHash SkProj SkAcc)) ;; SkAcc = (skeleton-accumulator ;; (MutableBag SkKey) @@ -122,7 +128,7 @@ (define assertions (make-hash)) (hash-for-each (skeleton-continuation-cache c) (lambda (a _) - (when (equal? (apply-projection a cs) cv) + (when (equal? (apply-projection (unscope-assertion a) cs) cv) (hash-set! assertions a #t)))) (skeleton-matched-constant assertions (make-hash))) (define cvt (hash-ref! (skeleton-continuation-table c) cs make-hash)) @@ -131,8 +137,9 @@ (define cache (make-bag)) (hash-for-each (skeleton-matched-constant-cache sc) (lambda (a _) - (define vars (apply-projection a vs)) - (bag-change! cache vars 1))) + (unpack-scoped-assertion [restriction-path term] a) + (when (or (not restriction-path) (equal? restriction-path vs)) + (bag-change! cache (apply-projection term vs) 1)))) (skeleton-accumulator cache (make-hasheq))) (define acc (hash-ref! (skeleton-matched-constant-table sc) vs make-accumulator)) (hash-set! (skeleton-accumulator-handlers acc) h #t) @@ -164,7 +171,18 @@ [else (error 'term-matches-class? "Invalid class: ~v" class)])) (define (subterm-matches-class? term path class) - (term-matches-class? (apply-projection-path term path) class)) + (term-matches-class? (apply-projection-path (unscope-assertion term) path) class)) + +(define (unscope-assertion scoped-assertion) + (match scoped-assertion + [(visibility-restriction _ term) term] + [term term])) + +(define-syntax-rule (unpack-scoped-assertion [path term] expr) + (define-values (path term) + (match expr + [(visibility-restriction p t) (values p t)] + [other (values #f other)]))) (define (update-path path pop-count index) (append (drop-right path pop-count) (list index))) @@ -215,14 +233,16 @@ (let ((sk (extend-skeleton! sk (skeleton-interest-desc i)))) (skcont-remove! (skeleton-node-continuation sk) i))) -(define (skeleton-modify! sk term0 restriction-path modify-skcont! modify-skconst! modify-skacc!) +(define (skeleton-modify! sk term0 modify-skcont! modify-skconst! modify-skacc!) + (unpack-scoped-assertion [restriction-path term0-term] term0) + (define (walk-node! sk term-stack) (match-define (skeleton-node continuation edges) sk) (modify-skcont! continuation term0) (hash-for-each (skeleton-continuation-table continuation) (lambda (constant-proj key-proj-handler) - (define constants (apply-projection term0 constant-proj)) + (define constants (apply-projection term0-term constant-proj)) (define proj-handler (hash-ref key-proj-handler constants #f)) (when proj-handler (modify-skconst! proj-handler term0) @@ -230,7 +250,7 @@ (lambda (variable-proj acc) (when (or (not restriction-path) (equal? restriction-path variable-proj)) - (define variables (apply-projection term0 variable-proj)) + (define variables (apply-projection term0-term variable-proj)) (modify-skacc! acc variables term0))))))) (for [(edge (in-list edges))] @@ -251,13 +271,13 @@ [(vector? term) (list->vector (cons 'list (vector->list term)))])) (walk-node! entry (cons new-pieces term-stack))))) - (walk-node! sk (list (vector 'list term0)))) + (walk-node! sk (list (vector 'list term0-term)))) (define (add-term-to-skcont! skcont term) (hash-set! (skeleton-continuation-cache skcont) term #t)) (define (add-term-to-skconst! skconst term) (hash-set! (skeleton-matched-constant-cache skconst) term #t)) -(define (add-term-to-skacc! skacc vars term) +(define (add-term-to-skacc! skacc vars _term) (match (bag-change! (skeleton-accumulator-cache skacc) vars 1) ['absent->present (hash-for-each (skeleton-accumulator-handlers skacc) @@ -266,10 +286,9 @@ ['present->present (void)])) -(define (add-assertion! sk term [restriction-path #f]) +(define (add-assertion! sk term) (skeleton-modify! sk term - restriction-path add-term-to-skcont! add-term-to-skconst! add-term-to-skacc!)) @@ -290,18 +309,16 @@ (void)]) (log-warning "Removing assertion not previously added: ~v" _term))) -(define (remove-assertion! sk term [restriction-path #f]) +(define (remove-assertion! sk term) (skeleton-modify! sk term - restriction-path remove-term-from-skcont! remove-term-from-skconst! remove-term-from-skacc!)) -(define (send-assertion! sk term [restriction-path #f]) +(define (send-assertion! sk term) (skeleton-modify! sk term - restriction-path void void (lambda (skacc vars _term) diff --git a/imperative/test-implementation.rkt b/imperative/test-implementation.rkt index 673332e..8a32e31 100644 --- a/imperative/test-implementation.rkt +++ b/imperative/test-implementation.rkt @@ -50,12 +50,11 @@ (define test-run-time (make-parameter 0)) (define test-gc-time (make-parameter 0)) -(define (asserted? v [restriction-path #f]) - (bag-member? (dataspace-assertions (final-dataspace)) (cons v restriction-path))) +(define (asserted? v) + (bag-member? (dataspace-assertions (final-dataspace)) v)) (define (final-assertions) - (for/set [(assertion-and-restriction-path (in-bag (dataspace-assertions (final-dataspace))))] - (car assertion-and-restriction-path))) + (bag->set (dataspace-assertions (final-dataspace)))) (define (emitted? v) (member v (collected-events))) diff --git a/imperative/test/core/nesting-confusion.rkt b/imperative/test/core/nesting-confusion.rkt index 2deafa3..4393499 100644 --- a/imperative/test/core/nesting-confusion.rkt +++ b/imperative/test/core/nesting-confusion.rkt @@ -118,3 +118,25 @@ (on-stop (printf "Nonspecific claim ~v retracted\n" detail)))))] no-crashes asserts-then-retractions) + +;;--------------------------------------------------------------------------- + +(test-case + [(dataspace #:name 'inner-dataspace + (spawn #:name 'inner-monitor + (during (inbound (claim $detail)) + (on-start (printf "Inner saw claim asserted\n")) + (on-stop (printf "Inner saw claim retracted\n"))))) + (spawn #:name 'claimant + (assert (claim 123)) + (on-start (printf "Outer claimant started\n")) + (on-stop (printf "Outer claimant stopped\n")) + (on-start (for [(i 5)] (flush!)) + (printf "Stopping outer claimant\n") + (stop-current-facet)))] + no-crashes + (expected-output "Outer claimant started" + "Inner saw claim asserted" + "Stopping outer claimant" + "Outer claimant stopped" + "Inner saw claim retracted"))