syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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:
Tony Garnock-Jones 2018-05-04 15:55:53 +01:00
parent ef4584a60f
commit ab64f71766
5 changed files with 75 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
syndicate/dataspace.rkt
View File

@ -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)))

17
syndicate/relay.rkt
View File

@ -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

57
syndicate/skeleton.rkt
View File

@ -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)

7
syndicate/test-implementation.rkt
View File

@ -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)))

22
syndicate/test/core/nesting-confusion.rkt
View File

@ -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"))