From 976741cd49333b638305d9a23842a3bf6ec4bdd9 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Fri, 21 Jun 2019 16:43:59 +0100 Subject: [PATCH] Cope with echo-server minimart-benchmark test: flat new-connection cost --- syndicate/HOWITWORKS.md | 36 +++++++++++++------- syndicate/skeleton.rkt | 74 ++++++++++++++++++++++++++--------------- 2 files changed, 72 insertions(+), 38 deletions(-) diff --git a/syndicate/HOWITWORKS.md b/syndicate/HOWITWORKS.md index 6c3c95e..10fd59f 100644 --- a/syndicate/HOWITWORKS.md +++ b/syndicate/HOWITWORKS.md @@ -1,7 +1,7 @@ # Efficient, Imperative Dataspaces for Conversational Concurrency Tony Garnock-Jones -20 October 2018 +20 October 2018; revised 21 June 2019

Abstract. The dataspace model of Conversational Concurrency [is great], but implementing it @@ -310,14 +310,17 @@ cases where handlers are dynamically installed. let (_, root) = index let (cache, table) = extend root s let constLocs = [h | (h,v) ∈ constantMap] - let constVals = [v | (h,v) ∈ constantMap] if constLocs not in table then table[constLocs] := {} + for v in cache + let key = projectMany v constLocs + if key not in table[constLocs] then + table[constLocs][key] := ({}, {}) + let (leafcache, _leaftable) = table[constLocs][key] + leafcache += v + let constVals = [v | (h,v) ∈ constantMap] if constVals not in table[constLocs] then - let leafcache = - { v | v ∈ cache, - projectMany v constLocs = constVals } - table[constLocs][constVals] := (leafcache, {}) + table[constLocs][constVals] := ({}, {}) let (leafcache, leaftable) = table[constLocs][constVals] if captureMap not in leaftable then let bag = empty_bag @@ -343,9 +346,9 @@ cases where handlers are dynamically installed. let (_, root) = index let (cache, table) = extend root s let constLocs = [h | (h,v) ∈ constantMap] - let constVals = [v | (h,v) ∈ constantMap] if constLocs not in table then return + let constVals = [v | (h,v) ∈ constantMap] if constVals not in table[constLocs] then return let (leafcache, leaftable) = table[constLocs][constVals] @@ -357,7 +360,7 @@ cases where handlers are dynamically installed. f_table -= f if f_table = {} then delete leaftable[captureMap] - if leaftable = {} then + if leafcache = {} and leaftable = {} then delete table[constLocs][constVals] if table[constLocs] = {} then delete table[constLocs] @@ -373,13 +376,16 @@ parameterized with different update procedures. by side-effect; in particular, the `m_handler` procedure may choose to invoke the callback passed to it. + Operation = { AddAssertion, RemoveAssertion, SendMessage } + modify :: Node -> + Operation -> V -> (Continuation -> V -> 1) -> (Leaf -> V -> 1) -> (Handler -> [V] -> 1) -> 1 - modify node v m_cont m_leaf m_handler = + modify node operation v m_cont m_leaf m_handler = walk-node node [outermost(v)] where walk-node :: Node -> [V] -> 1 @@ -397,6 +403,8 @@ parameterized with different update procedures. m_cont cont v for constLocs in table let consts = projectMany v constLocs + if operation = AddAssertion and consts not in table[constLocs] then + table[constLocs][consts] := ({}, {}) if consts in table[constLocs] then let leaf@(leafcache, leaftable) = table[constLocs][consts] @@ -405,6 +413,10 @@ parameterized with different update procedures. let handler = leaftable[captureMap] let vs = projectMany v captureMap m_handler handler vs + if operation = RemoveAssertion and leafcache = {} and leaftable = {} then + delete table[constLocs][consts] + if table[constLocs] = {} then + delete table[constLocs] The `outermost` constructor applied to `v` at the top of `modify` is necessary because every path in the trie structure embodied in each @@ -427,9 +439,9 @@ check followed by zero or more (move, check) pairs. cache[v] += delta let is_present = v in cache if not was_present and is_present then - modify root v add_cont add_leaf add_handler + modify root AddAssertion v add_cont add_leaf add_handler if was_present and not is_present then - modify root v del_cont del_leaf del_handler + modify root RemoveAssertion v del_cont del_leaf del_handler where add_cont (cache, _) v = cache += v add_leaf (leafcache, _) v = leafcache += v @@ -472,7 +484,7 @@ processed first, no glitch will be detected. sendMessage :: Index -> V -> 1 sendMessage (_, root) v = - modify root v send_cont send_leaf send_handler + modify root SendMessage v send_cont send_leaf send_handler where send_cont _ _ = () send_leaf _ _ = () diff --git a/syndicate/skeleton.rkt b/syndicate/skeleton.rkt index c50213b..5ee2c1a 100644 --- a/syndicate/skeleton.rkt +++ b/syndicate/skeleton.rkt @@ -122,17 +122,21 @@ (define (make-empty-skeleton) (make-empty-skeleton/cache (make-hash))) +(define (make-empty-matched-constant) + (skeleton-matched-constant (make-hash) (make-hash))) + (define (skcont-add! c i) (match-define (skeleton-interest _desc cs cv vs h _cleanup) i) - (define (make-matched-constant) - (define assertions (make-hash)) + (define (classify-assertions) + (define cvt (make-hash)) (hash-for-each (skeleton-continuation-cache c) (lambda (a _) - (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)) - (define sc (hash-ref! cvt cv make-matched-constant)) + (define avs (apply-projection (unscope-assertion a) cs)) + (define sc (hash-ref! cvt avs make-empty-matched-constant)) + (hash-set! (skeleton-matched-constant-cache sc) a #t))) + cvt) + (define cvt (hash-ref! (skeleton-continuation-table c) cs classify-assertions)) + (define sc (hash-ref! cvt cv make-empty-matched-constant)) (define (make-accumulator) (define cache (make-bag)) (hash-for-each (skeleton-matched-constant-cache sc) @@ -145,6 +149,10 @@ (hash-set! (skeleton-accumulator-handlers acc) h #t) (for [(vars (in-bag (skeleton-accumulator-cache acc)))] (apply h '+ vars))) +(define (skeleton-matched-constant-empty? sc) + (match-define (skeleton-matched-constant cache table) sc) + (and (hash-empty? cache) (hash-empty? table))) + (define (skcont-remove! c i) (match-define (skeleton-interest _desc cs cv vs h cleanup) i) (define cvt (hash-ref (skeleton-continuation-table c) cs #f)) @@ -158,7 +166,7 @@ (hash-remove! (skeleton-accumulator-handlers acc) h) (when (hash-empty? (skeleton-accumulator-handlers acc)) (hash-remove! (skeleton-matched-constant-table sc) vs))) - (when (hash-empty? (skeleton-matched-constant-table sc)) + (when (skeleton-matched-constant-empty? sc) (hash-remove! cvt cv))) (when (hash-empty? cvt) (hash-remove! (skeleton-continuation-table c) cs)))) @@ -259,29 +267,36 @@ (let ((sk (extend-skeleton! sk (skeleton-interest-desc i)))) (skcont-remove! (skeleton-node-continuation sk) i))) -(define (skeleton-modify! sk term0 modify-skcont! modify-skconst! modify-skacc!) +(define (skeleton-modify! sk term0 modify-skcont! on-missing-skconst 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-term constant-proj)) - (define proj-handler (hash-ref key-proj-handler constants #f)) - (when proj-handler - (modify-skconst! proj-handler term0) - (hash-for-each (skeleton-matched-constant-table proj-handler) - (lambda (variable-proj acc) - ;; (when restriction-path - ;; (log-info "Restriction path ~v in effect; variable-proj is ~v, and term is ~v" - ;; restriction-path - ;; variable-proj - ;; term0)) - (when (unrestricted? variable-proj restriction-path) - (define vars (apply-projection term0-term variable-proj)) - (modify-skacc! acc vars term0))))))) + (let ((sct (skeleton-continuation-table continuation)) + (constant-projections-to-remove '())) + (hash-for-each sct + (lambda (constant-proj key-proj-handler) + (define constants (apply-projection term0-term constant-proj)) + (define proj-handler + (hash-ref key-proj-handler + constants + (lambda () (on-missing-skconst key-proj-handler constants)))) + (when proj-handler + (when (eq? (modify-skconst! proj-handler term0) 'remove-check) + (when (skeleton-matched-constant-empty? proj-handler) + (hash-remove! key-proj-handler constants) + (when (hash-empty? key-proj-handler) + (set! constant-projections-to-remove + (cons constant-proj constant-projections-to-remove))))) + (hash-for-each (skeleton-matched-constant-table proj-handler) + (lambda (variable-proj acc) + (when (unrestricted? variable-proj restriction-path) + (define vars (apply-projection term0-term variable-proj)) + (modify-skacc! acc vars term0))))))) + (for-each (lambda (constant-proj) (hash-remove! sct constant-proj)) + constant-projections-to-remove)) (for [(edge (in-list edges))] (match-define (cons (skeleton-selector pop-count index) table) edge) @@ -321,13 +336,18 @@ (skeleton-modify! sk term add-term-to-skcont! + (lambda (cv-table cv) + (let ((sc (make-empty-matched-constant))) + (hash-set! cv-table cv sc) + sc)) add-term-to-skconst! add-term-to-skacc!)) (define (remove-term-from-skcont! skcont term) (hash-remove! (skeleton-continuation-cache skcont) term)) (define (remove-term-from-skconst! skconst term) - (hash-remove! (skeleton-matched-constant-cache skconst) term)) + (hash-remove! (skeleton-matched-constant-cache skconst) term) + 'remove-check) (define (remove-term-from-skacc! skacc vars _term) (define cache (skeleton-accumulator-cache skacc)) ;; (log-info ">>>>>> At removal time for ~v, cache has ~v" _term (hash-ref cache vars 0)) @@ -345,6 +365,7 @@ (skeleton-modify! sk term remove-term-from-skcont! + (lambda (_cv-table _cv) #f) remove-term-from-skconst! remove-term-from-skacc!)) @@ -352,6 +373,7 @@ (skeleton-modify! sk term void + (lambda (_cv-table _cv) #f) void (lambda (skacc vars _term) (hash-for-each (skeleton-accumulator-handlers skacc)