Restriction-paths: right idea (?), wrong implementation. This time maybe.
Instead of having restriction-paths as an adjunct to a change, they're more propertly a part of each assertion itself. The new `skeleton.rkt` keeps an optional restriction-path with each assertion, treating it as distinct from its underlying assertion. The idea of not signalling changes in assertions that have a restriction-path mismatch stays.
This commit is contained in:
parent
ef4584a60f
commit
ab64f71766
|
@ -361,15 +361,15 @@
|
||||||
(push-script! ac k)])
|
(push-script! ac k)])
|
||||||
(run-all-pending-scripts! ds))))
|
(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))
|
(when (not (bag-empty? delta))
|
||||||
(define ds-assertions (dataspace-assertions ds))
|
(define ds-assertions (dataspace-assertions ds))
|
||||||
(define rt (dataspace-routing-table ds))
|
(define rt (dataspace-routing-table ds))
|
||||||
(define new-cleanup-changes
|
(define new-cleanup-changes
|
||||||
(for/fold [(cleanup-changes (actor-cleanup-changes ac))] [((a count) (in-bag/count delta))]
|
(for/fold [(cleanup-changes (actor-cleanup-changes ac))] [((a count) (in-bag/count delta))]
|
||||||
(match (bag-change! ds-assertions (cons a restriction-path) count)
|
(match (bag-change! ds-assertions a count)
|
||||||
['present->absent (remove-assertion! rt a restriction-path)]
|
['present->absent (remove-assertion! rt a)]
|
||||||
['absent->present (add-assertion! rt a restriction-path)]
|
['absent->present (add-assertion! rt a)]
|
||||||
;; 'absent->absent absurd
|
;; 'absent->absent absurd
|
||||||
['present->present (void)]) ;; i.e. no visible change
|
['present->present (void)]) ;; i.e. no visible change
|
||||||
(define-values (updated-bag _summary) (bag-change cleanup-changes a (- count)))
|
(define-values (updated-bag _summary) (bag-change cleanup-changes a (- count)))
|
||||||
|
|
|
@ -84,17 +84,16 @@
|
||||||
outer-capture-proj
|
outer-capture-proj
|
||||||
(lambda (op . captured-values)
|
(lambda (op . captured-values)
|
||||||
(define term (inbound (instantiate-term->value x 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"
|
;; (log-info "~a => ~a ~a ~v"
|
||||||
;; outer-facet
|
;; outer-facet
|
||||||
;; inner-facet
|
;; inner-facet
|
||||||
;; op
|
;; op
|
||||||
;; term)
|
;; assertion)
|
||||||
(match op
|
(match op
|
||||||
['+ (apply-patch! inner-ds inner-actor (bag term +1) inner-capture-proj)]
|
['+ (apply-patch! inner-ds inner-actor (bag assertion +1))]
|
||||||
['- (apply-patch! inner-ds inner-actor (bag term -1) inner-capture-proj)]
|
['- (apply-patch! inner-ds inner-actor (bag assertion -1))]
|
||||||
['! (send-assertion! (dataspace-routing-table inner-ds)
|
['! (send-assertion! (dataspace-routing-table inner-ds) assertion)])
|
||||||
term
|
|
||||||
inner-capture-proj)])
|
|
||||||
(schedule-inner!))
|
(schedule-inner!))
|
||||||
(lambda (cache)
|
(lambda (cache)
|
||||||
(apply-patch!
|
(apply-patch!
|
||||||
|
@ -102,8 +101,10 @@
|
||||||
inner-actor
|
inner-actor
|
||||||
(for/bag/count [(captured-values (in-bag cache))]
|
(for/bag/count [(captured-values (in-bag cache))]
|
||||||
;; (log-info "~a (cleanup) ~v" inner-actor term)
|
;; (log-info "~a (cleanup) ~v" inner-actor term)
|
||||||
(values (inbound (instantiate-term->value x captured-values)) -1))
|
(values (visibility-restriction
|
||||||
inner-capture-proj)
|
inner-capture-proj
|
||||||
|
(inbound (instantiate-term->value x captured-values)))
|
||||||
|
-1)))
|
||||||
(schedule-inner!))))
|
(schedule-inner!))))
|
||||||
(add-endpoint-if-live! outer-facet
|
(add-endpoint-if-live! outer-facet
|
||||||
inbound-endpoints
|
inbound-endpoints
|
||||||
|
|
|
@ -3,14 +3,13 @@
|
||||||
;; In particular, they efficiently connect assertions to matching interests.
|
;; In particular, they efficiently connect assertions to matching interests.
|
||||||
|
|
||||||
(provide (struct-out skeleton-interest)
|
(provide (struct-out skeleton-interest)
|
||||||
|
(struct-out visibility-restriction)
|
||||||
make-empty-skeleton
|
make-empty-skeleton
|
||||||
add-interest!
|
add-interest!
|
||||||
remove-interest!
|
remove-interest!
|
||||||
add-assertion!
|
add-assertion!
|
||||||
remove-assertion!
|
remove-assertion!
|
||||||
send-assertion!
|
send-assertion!)
|
||||||
apply-projection
|
|
||||||
apply-projection-path)
|
|
||||||
|
|
||||||
(require syndicate/support/struct)
|
(require syndicate/support/struct)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
|
@ -23,6 +22,13 @@
|
||||||
|
|
||||||
(module+ test (require rackunit))
|
(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,
|
;; A `Skeleton` is a structural guard on an assertion: essentially,
|
||||||
;; specification of (the outline of) its shape; its silhouette.
|
;; specification of (the outline of) its shape; its silhouette.
|
||||||
;; Following a skeleton's structure leads to zero or more `SkCont`s.
|
;; Following a skeleton's structure leads to zero or more `SkCont`s.
|
||||||
|
@ -48,10 +54,10 @@
|
||||||
;; containing the structures.
|
;; containing the structures.
|
||||||
;;
|
;;
|
||||||
;; SkCont = (skeleton-continuation
|
;; SkCont = (skeleton-continuation
|
||||||
;; (MutableSet Assertion)
|
;; (MutableSet ScopedAssertion)
|
||||||
;; (MutableHash SkProj (MutableHash SkKey SkConst)))
|
;; (MutableHash SkProj (MutableHash SkKey SkConst)))
|
||||||
;; SkConst = (skeleton-matched-constant
|
;; SkConst = (skeleton-matched-constant
|
||||||
;; (MutableSet Assertion)
|
;; (MutableSet ScopedAssertion)
|
||||||
;; (MutableHash SkProj SkAcc))
|
;; (MutableHash SkProj SkAcc))
|
||||||
;; SkAcc = (skeleton-accumulator
|
;; SkAcc = (skeleton-accumulator
|
||||||
;; (MutableBag SkKey)
|
;; (MutableBag SkKey)
|
||||||
|
@ -122,7 +128,7 @@
|
||||||
(define assertions (make-hash))
|
(define assertions (make-hash))
|
||||||
(hash-for-each (skeleton-continuation-cache c)
|
(hash-for-each (skeleton-continuation-cache c)
|
||||||
(lambda (a _)
|
(lambda (a _)
|
||||||
(when (equal? (apply-projection a cs) cv)
|
(when (equal? (apply-projection (unscope-assertion a) cs) cv)
|
||||||
(hash-set! assertions a #t))))
|
(hash-set! assertions a #t))))
|
||||||
(skeleton-matched-constant assertions (make-hash)))
|
(skeleton-matched-constant assertions (make-hash)))
|
||||||
(define cvt (hash-ref! (skeleton-continuation-table c) cs make-hash))
|
(define cvt (hash-ref! (skeleton-continuation-table c) cs make-hash))
|
||||||
|
@ -131,8 +137,9 @@
|
||||||
(define cache (make-bag))
|
(define cache (make-bag))
|
||||||
(hash-for-each (skeleton-matched-constant-cache sc)
|
(hash-for-each (skeleton-matched-constant-cache sc)
|
||||||
(lambda (a _)
|
(lambda (a _)
|
||||||
(define vars (apply-projection a vs))
|
(unpack-scoped-assertion [restriction-path term] a)
|
||||||
(bag-change! cache vars 1)))
|
(when (or (not restriction-path) (equal? restriction-path vs))
|
||||||
|
(bag-change! cache (apply-projection term vs) 1))))
|
||||||
(skeleton-accumulator cache (make-hasheq)))
|
(skeleton-accumulator cache (make-hasheq)))
|
||||||
(define acc (hash-ref! (skeleton-matched-constant-table sc) vs make-accumulator))
|
(define acc (hash-ref! (skeleton-matched-constant-table sc) vs make-accumulator))
|
||||||
(hash-set! (skeleton-accumulator-handlers acc) h #t)
|
(hash-set! (skeleton-accumulator-handlers acc) h #t)
|
||||||
|
@ -164,7 +171,18 @@
|
||||||
[else (error 'term-matches-class? "Invalid class: ~v" class)]))
|
[else (error 'term-matches-class? "Invalid class: ~v" class)]))
|
||||||
|
|
||||||
(define (subterm-matches-class? term path 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)
|
(define (update-path path pop-count index)
|
||||||
(append (drop-right path pop-count) (list index)))
|
(append (drop-right path pop-count) (list index)))
|
||||||
|
@ -215,14 +233,16 @@
|
||||||
(let ((sk (extend-skeleton! sk (skeleton-interest-desc i))))
|
(let ((sk (extend-skeleton! sk (skeleton-interest-desc i))))
|
||||||
(skcont-remove! (skeleton-node-continuation sk) 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)
|
(define (walk-node! sk term-stack)
|
||||||
(match-define (skeleton-node continuation edges) sk)
|
(match-define (skeleton-node continuation edges) sk)
|
||||||
|
|
||||||
(modify-skcont! continuation term0)
|
(modify-skcont! continuation term0)
|
||||||
(hash-for-each (skeleton-continuation-table continuation)
|
(hash-for-each (skeleton-continuation-table continuation)
|
||||||
(lambda (constant-proj key-proj-handler)
|
(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))
|
(define proj-handler (hash-ref key-proj-handler constants #f))
|
||||||
(when proj-handler
|
(when proj-handler
|
||||||
(modify-skconst! proj-handler term0)
|
(modify-skconst! proj-handler term0)
|
||||||
|
@ -230,7 +250,7 @@
|
||||||
(lambda (variable-proj acc)
|
(lambda (variable-proj acc)
|
||||||
(when (or (not restriction-path)
|
(when (or (not restriction-path)
|
||||||
(equal? restriction-path variable-proj))
|
(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)))))))
|
(modify-skacc! acc variables term0)))))))
|
||||||
|
|
||||||
(for [(edge (in-list edges))]
|
(for [(edge (in-list edges))]
|
||||||
|
@ -251,13 +271,13 @@
|
||||||
[(vector? term) (list->vector (cons 'list (vector->list term)))]))
|
[(vector? term) (list->vector (cons 'list (vector->list term)))]))
|
||||||
(walk-node! entry (cons new-pieces term-stack)))))
|
(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)
|
(define (add-term-to-skcont! skcont term)
|
||||||
(hash-set! (skeleton-continuation-cache skcont) term #t))
|
(hash-set! (skeleton-continuation-cache skcont) term #t))
|
||||||
(define (add-term-to-skconst! skconst term)
|
(define (add-term-to-skconst! skconst term)
|
||||||
(hash-set! (skeleton-matched-constant-cache skconst) term #t))
|
(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)
|
(match (bag-change! (skeleton-accumulator-cache skacc) vars 1)
|
||||||
['absent->present
|
['absent->present
|
||||||
(hash-for-each (skeleton-accumulator-handlers skacc)
|
(hash-for-each (skeleton-accumulator-handlers skacc)
|
||||||
|
@ -266,10 +286,9 @@
|
||||||
['present->present
|
['present->present
|
||||||
(void)]))
|
(void)]))
|
||||||
|
|
||||||
(define (add-assertion! sk term [restriction-path #f])
|
(define (add-assertion! sk term)
|
||||||
(skeleton-modify! sk
|
(skeleton-modify! sk
|
||||||
term
|
term
|
||||||
restriction-path
|
|
||||||
add-term-to-skcont!
|
add-term-to-skcont!
|
||||||
add-term-to-skconst!
|
add-term-to-skconst!
|
||||||
add-term-to-skacc!))
|
add-term-to-skacc!))
|
||||||
|
@ -290,18 +309,16 @@
|
||||||
(void)])
|
(void)])
|
||||||
(log-warning "Removing assertion not previously added: ~v" _term)))
|
(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
|
(skeleton-modify! sk
|
||||||
term
|
term
|
||||||
restriction-path
|
|
||||||
remove-term-from-skcont!
|
remove-term-from-skcont!
|
||||||
remove-term-from-skconst!
|
remove-term-from-skconst!
|
||||||
remove-term-from-skacc!))
|
remove-term-from-skacc!))
|
||||||
|
|
||||||
(define (send-assertion! sk term [restriction-path #f])
|
(define (send-assertion! sk term)
|
||||||
(skeleton-modify! sk
|
(skeleton-modify! sk
|
||||||
term
|
term
|
||||||
restriction-path
|
|
||||||
void
|
void
|
||||||
void
|
void
|
||||||
(lambda (skacc vars _term)
|
(lambda (skacc vars _term)
|
||||||
|
|
|
@ -50,12 +50,11 @@
|
||||||
(define test-run-time (make-parameter 0))
|
(define test-run-time (make-parameter 0))
|
||||||
(define test-gc-time (make-parameter 0))
|
(define test-gc-time (make-parameter 0))
|
||||||
|
|
||||||
(define (asserted? v [restriction-path #f])
|
(define (asserted? v)
|
||||||
(bag-member? (dataspace-assertions (final-dataspace)) (cons v restriction-path)))
|
(bag-member? (dataspace-assertions (final-dataspace)) v))
|
||||||
|
|
||||||
(define (final-assertions)
|
(define (final-assertions)
|
||||||
(for/set [(assertion-and-restriction-path (in-bag (dataspace-assertions (final-dataspace))))]
|
(bag->set (dataspace-assertions (final-dataspace))))
|
||||||
(car assertion-and-restriction-path)))
|
|
||||||
|
|
||||||
(define (emitted? v)
|
(define (emitted? v)
|
||||||
(member v (collected-events)))
|
(member v (collected-events)))
|
||||||
|
|
|
@ -118,3 +118,25 @@
|
||||||
(on-stop (printf "Nonspecific claim ~v retracted\n" detail)))))]
|
(on-stop (printf "Nonspecific claim ~v retracted\n" detail)))))]
|
||||||
no-crashes
|
no-crashes
|
||||||
asserts-then-retractions)
|
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"))
|
||||||
|
|
Loading…
Reference in New Issue