Cope with echo-server minimart-benchmark test: flat new-connection cost

This commit is contained in:
Tony Garnock-Jones 2019-06-21 16:43:59 +01:00
parent df6918bc6f
commit 976741cd49
2 changed files with 72 additions and 38 deletions

View File

@ -1,7 +1,7 @@
# Efficient, Imperative Dataspaces for Conversational Concurrency # Efficient, Imperative Dataspaces for Conversational Concurrency
Tony Garnock-Jones <tonyg@leastfixedpoint.com> Tony Garnock-Jones <tonyg@leastfixedpoint.com>
20 October 2018 20 October 2018; revised 21 June 2019
<p style="font-size:90%"><strong>Abstract.</strong> The dataspace <p style="font-size:90%"><strong>Abstract.</strong> The dataspace
model of Conversational Concurrency [is great], but implementing it model of Conversational Concurrency [is great], but implementing it
@ -310,14 +310,17 @@ cases where handlers are dynamically installed.
let (_, root) = index let (_, root) = index
let (cache, table) = extend root s let (cache, table) = extend root s
let constLocs = [h | (h,v) ∈ constantMap] let constLocs = [h | (h,v) ∈ constantMap]
let constVals = [v | (h,v) ∈ constantMap]
if constLocs not in table then if constLocs not in table then
table[constLocs] := {} 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 if constVals not in table[constLocs] then
let leafcache = table[constLocs][constVals] := ({}, {})
{ v | v ∈ cache,
projectMany v constLocs = constVals }
table[constLocs][constVals] := (leafcache, {})
let (leafcache, leaftable) = table[constLocs][constVals] let (leafcache, leaftable) = table[constLocs][constVals]
if captureMap not in leaftable then if captureMap not in leaftable then
let bag = empty_bag let bag = empty_bag
@ -343,9 +346,9 @@ cases where handlers are dynamically installed.
let (_, root) = index let (_, root) = index
let (cache, table) = extend root s let (cache, table) = extend root s
let constLocs = [h | (h,v) ∈ constantMap] let constLocs = [h | (h,v) ∈ constantMap]
let constVals = [v | (h,v) ∈ constantMap]
if constLocs not in table then if constLocs not in table then
return return
let constVals = [v | (h,v) ∈ constantMap]
if constVals not in table[constLocs] then if constVals not in table[constLocs] then
return return
let (leafcache, leaftable) = table[constLocs][constVals] let (leafcache, leaftable) = table[constLocs][constVals]
@ -357,7 +360,7 @@ cases where handlers are dynamically installed.
f_table -= f f_table -= f
if f_table = {} then if f_table = {} then
delete leaftable[captureMap] delete leaftable[captureMap]
if leaftable = {} then if leafcache = {} and leaftable = {} then
delete table[constLocs][constVals] delete table[constLocs][constVals]
if table[constLocs] = {} then if table[constLocs] = {} then
delete table[constLocs] delete table[constLocs]
@ -373,13 +376,16 @@ parameterized with different update procedures.
by side-effect; in particular, the `m_handler` procedure may choose by side-effect; in particular, the `m_handler` procedure may choose
to invoke the callback passed to it. to invoke the callback passed to it.
Operation = { AddAssertion, RemoveAssertion, SendMessage }
modify :: Node -> modify :: Node ->
Operation ->
V -> V ->
(Continuation -> V -> 1) -> (Continuation -> V -> 1) ->
(Leaf -> V -> 1) -> (Leaf -> V -> 1) ->
(Handler -> [V] -> 1) -> (Handler -> [V] -> 1) ->
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)] walk-node node [outermost(v)]
where where
walk-node :: Node -> [V] -> 1 walk-node :: Node -> [V] -> 1
@ -397,6 +403,8 @@ parameterized with different update procedures.
m_cont cont v m_cont cont v
for constLocs in table for constLocs in table
let consts = projectMany v constLocs let consts = projectMany v constLocs
if operation = AddAssertion and consts not in table[constLocs] then
table[constLocs][consts] := ({}, {})
if consts in table[constLocs] then if consts in table[constLocs] then
let leaf@(leafcache, leaftable) = let leaf@(leafcache, leaftable) =
table[constLocs][consts] table[constLocs][consts]
@ -405,6 +413,10 @@ parameterized with different update procedures.
let handler = leaftable[captureMap] let handler = leaftable[captureMap]
let vs = projectMany v captureMap let vs = projectMany v captureMap
m_handler handler vs 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 The `outermost` constructor applied to `v` at the top of `modify` is
necessary because every path in the trie structure embodied in each 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 cache[v] += delta
let is_present = v in cache let is_present = v in cache
if not was_present and is_present then 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 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 where
add_cont (cache, _) v = cache += v add_cont (cache, _) v = cache += v
add_leaf (leafcache, _) v = leafcache += v add_leaf (leafcache, _) v = leafcache += v
@ -472,7 +484,7 @@ processed first, no glitch will be detected.
sendMessage :: Index -> V -> 1 sendMessage :: Index -> V -> 1
sendMessage (_, root) v = sendMessage (_, root) v =
modify root v send_cont send_leaf send_handler modify root SendMessage v send_cont send_leaf send_handler
where where
send_cont _ _ = () send_cont _ _ = ()
send_leaf _ _ = () send_leaf _ _ = ()

View File

@ -122,17 +122,21 @@
(define (make-empty-skeleton) (define (make-empty-skeleton)
(make-empty-skeleton/cache (make-hash))) (make-empty-skeleton/cache (make-hash)))
(define (make-empty-matched-constant)
(skeleton-matched-constant (make-hash) (make-hash)))
(define (skcont-add! c i) (define (skcont-add! c i)
(match-define (skeleton-interest _desc cs cv vs h _cleanup) i) (match-define (skeleton-interest _desc cs cv vs h _cleanup) i)
(define (make-matched-constant) (define (classify-assertions)
(define assertions (make-hash)) (define cvt (make-hash))
(hash-for-each (skeleton-continuation-cache c) (hash-for-each (skeleton-continuation-cache c)
(lambda (a _) (lambda (a _)
(when (equal? (apply-projection (unscope-assertion a) cs) cv) (define avs (apply-projection (unscope-assertion a) cs))
(hash-set! assertions a #t)))) (define sc (hash-ref! cvt avs make-empty-matched-constant))
(skeleton-matched-constant assertions (make-hash))) (hash-set! (skeleton-matched-constant-cache sc) a #t)))
(define cvt (hash-ref! (skeleton-continuation-table c) cs make-hash)) cvt)
(define sc (hash-ref! cvt cv make-matched-constant)) (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 (make-accumulator)
(define cache (make-bag)) (define cache (make-bag))
(hash-for-each (skeleton-matched-constant-cache sc) (hash-for-each (skeleton-matched-constant-cache sc)
@ -145,6 +149,10 @@
(hash-set! (skeleton-accumulator-handlers acc) h #t) (hash-set! (skeleton-accumulator-handlers acc) h #t)
(for [(vars (in-bag (skeleton-accumulator-cache acc)))] (apply h '+ vars))) (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) (define (skcont-remove! c i)
(match-define (skeleton-interest _desc cs cv vs h cleanup) i) (match-define (skeleton-interest _desc cs cv vs h cleanup) i)
(define cvt (hash-ref (skeleton-continuation-table c) cs #f)) (define cvt (hash-ref (skeleton-continuation-table c) cs #f))
@ -158,7 +166,7 @@
(hash-remove! (skeleton-accumulator-handlers acc) h) (hash-remove! (skeleton-accumulator-handlers acc) h)
(when (hash-empty? (skeleton-accumulator-handlers acc)) (when (hash-empty? (skeleton-accumulator-handlers acc))
(hash-remove! (skeleton-matched-constant-table sc) vs))) (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))) (hash-remove! cvt cv)))
(when (hash-empty? cvt) (when (hash-empty? cvt)
(hash-remove! (skeleton-continuation-table c) cs)))) (hash-remove! (skeleton-continuation-table c) cs))))
@ -259,29 +267,36 @@
(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 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) (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) (let ((sct (skeleton-continuation-table continuation))
(lambda (constant-proj key-proj-handler) (constant-projections-to-remove '()))
(define constants (apply-projection term0-term constant-proj)) (hash-for-each sct
(define proj-handler (hash-ref key-proj-handler constants #f)) (lambda (constant-proj key-proj-handler)
(when proj-handler (define constants (apply-projection term0-term constant-proj))
(modify-skconst! proj-handler term0) (define proj-handler
(hash-for-each (skeleton-matched-constant-table proj-handler) (hash-ref key-proj-handler
(lambda (variable-proj acc) constants
;; (when restriction-path (lambda () (on-missing-skconst key-proj-handler constants))))
;; (log-info "Restriction path ~v in effect; variable-proj is ~v, and term is ~v" (when proj-handler
;; restriction-path (when (eq? (modify-skconst! proj-handler term0) 'remove-check)
;; variable-proj (when (skeleton-matched-constant-empty? proj-handler)
;; term0)) (hash-remove! key-proj-handler constants)
(when (unrestricted? variable-proj restriction-path) (when (hash-empty? key-proj-handler)
(define vars (apply-projection term0-term variable-proj)) (set! constant-projections-to-remove
(modify-skacc! acc vars term0))))))) (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))] (for [(edge (in-list edges))]
(match-define (cons (skeleton-selector pop-count index) table) edge) (match-define (cons (skeleton-selector pop-count index) table) edge)
@ -321,13 +336,18 @@
(skeleton-modify! sk (skeleton-modify! sk
term term
add-term-to-skcont! 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-skconst!
add-term-to-skacc!)) add-term-to-skacc!))
(define (remove-term-from-skcont! skcont term) (define (remove-term-from-skcont! skcont term)
(hash-remove! (skeleton-continuation-cache skcont) term)) (hash-remove! (skeleton-continuation-cache skcont) term))
(define (remove-term-from-skconst! skconst 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 (remove-term-from-skacc! skacc vars _term)
(define cache (skeleton-accumulator-cache skacc)) (define cache (skeleton-accumulator-cache skacc))
;; (log-info ">>>>>> At removal time for ~v, cache has ~v" _term (hash-ref cache vars 0)) ;; (log-info ">>>>>> At removal time for ~v, cache has ~v" _term (hash-ref cache vars 0))
@ -345,6 +365,7 @@
(skeleton-modify! sk (skeleton-modify! sk
term term
remove-term-from-skcont! remove-term-from-skcont!
(lambda (_cv-table _cv) #f)
remove-term-from-skconst! remove-term-from-skconst!
remove-term-from-skacc!)) remove-term-from-skacc!))
@ -352,6 +373,7 @@
(skeleton-modify! sk (skeleton-modify! sk
term term
void void
(lambda (_cv-table _cv) #f)
void void
(lambda (skacc vars _term) (lambda (skacc vars _term)
(hash-for-each (skeleton-accumulator-handlers skacc) (hash-for-each (skeleton-accumulator-handlers skacc)