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

Avoid some needless routing change notifications, at a cost of slightly less wieldy code

This commit is contained in:
Tony Garnock-Jones 2013-11-01 11:10:09 -04:00
parent 44d08295be
commit 4ce46c562a
1 changed files with 56 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

81
minimart/core.rkt
View File

@ -49,6 +49,10 @@
;; Behavior : maybe event * state -> transition ;; Behavior : maybe event * state -> transition
(struct transition (state actions) #:transparent) (struct transition (state actions) #:transparent)
;; Process table maps to these; idea is to avoid redundant signalling
;; of routing-updates where possible
(struct trigger-guard (process downward-routes) #:transparent)
(define (drop-route r) (define (drop-route r)
(match-define (route s? p ml l) r) (match-define (route s? p ml l) r)
(and (positive? ml) (route s? p (- ml 1) l))) (and (positive? ml) (route s? p (- ml 1) l)))
@ -146,22 +150,25 @@
(match t (match t
[#f w] [#f w]
[(transition new-state new-actions) [(transition new-state new-actions)
(let* ((w (transform-process pid w (lambda (p) (let* ((w (transform-process pid w
(when (and (log-events-and-actions?) (lambda (p)
(not (null? (flatten new-actions)))) (when (and (log-events-and-actions?)
(log-info "~a: ~v <-- ~v ~v" (not (null? (flatten new-actions))))
(reverse (cons pid (pid-stack))) (log-info "~a: ~v <-- ~v ~v"
new-actions (reverse (cons pid (pid-stack)))
(process-behavior p) new-actions
(if (world? new-state) (process-behavior p)
"#<world>" (if (world? new-state)
new-state))) "#<world>"
(struct-copy process p [state new-state]))))) new-state)))
(struct-copy process p [state new-state]))
values)))
(enqueue-actions w pid new-actions))])) (enqueue-actions w pid new-actions))]))
(define (step-children w) (define (step-children w)
(let-values (((w step-taken?) (let-values (((w step-taken?)
(for/fold ([w w] [step-taken? #f]) (((pid p) (in-hash (world-process-table w)))) (for/fold ([w w] [step-taken? #f]) (((pid g) (in-hash (world-process-table w))))
(match-define (trigger-guard p _) g)
(define t (deliver-event #f pid p)) (define t (deliver-event #f pid p))
(values (apply-transition pid t w) (values (apply-transition pid t w)
(or step-taken? (transition? t)))))) (or step-taken? (transition? t))))))
@ -187,22 +194,32 @@
(dispatch-event e w)) (dispatch-event e w))
'())) '()))
(define (transform-process pid w f) (define (transform-process pid w fp frs)
(define p (hash-ref (world-process-table w) pid)) (match (hash-ref (world-process-table w) pid)
(if p [#f w]
(struct-copy world w [process-table (hash-set (world-process-table w) pid (f p))]) [(trigger-guard p downward-rs)
w)) (struct-copy world w
[process-table (hash-set (world-process-table w)
pid
(trigger-guard (fp p) (frs downward-rs)))])]))
(define (enqueue-event e w) (define (enqueue-event e w)
(struct-copy world w [event-queue (enqueue (world-event-queue w) e)])) (struct-copy world w [event-queue (enqueue (world-event-queue w) e)]))
(define (upward-routes-change-ignorable? pid w rs)
(match (hash-ref (world-process-table w) pid)
[#f #t]
[(trigger-guard p _) (equal? (process-routes p) rs)]))
(define ((perform-action pid a) w) (define ((perform-action pid a) w)
(match a (match a
[(? process? new-p) [(? process? new-p)
(let* ((new-pid (world-next-pid w)) (let* ((new-pid (world-next-pid w))
(w (struct-copy world w [next-pid (+ new-pid 1)])) (w (struct-copy world w [next-pid (+ new-pid 1)]))
(w (struct-copy world w [process-table (w (struct-copy world w [process-table
(hash-set (world-process-table w) new-pid new-p)]))) (hash-set (world-process-table w)
new-pid
(trigger-guard new-p '()))])))
(log-info "Spawned process ~a ~v ~v" new-pid (process-behavior new-p) (process-state new-p)) (log-info "Spawned process ~a ~v ~v" new-pid (process-behavior new-p) (process-state new-p))
(issue-routing-update w))] (issue-routing-update w))]
[(quit) [(quit)
@ -210,15 +227,22 @@
(let* ((w (struct-copy world w [process-table (hash-remove (world-process-table w) pid)]))) (let* ((w (struct-copy world w [process-table (hash-remove (world-process-table w) pid)])))
(issue-routing-update w))] (issue-routing-update w))]
[(routing-update routes) [(routing-update routes)
(let* ((w (transform-process pid w (lambda (p) (struct-copy process p [routes routes]))))) (if (upward-routes-change-ignorable? pid w routes)
(issue-routing-update w))] (transition w '())
(let* ((w (transform-process pid w
(lambda (p) (struct-copy process p [routes routes]))
values)))
(issue-routing-update w)))]
[(message body meta-level feedback?) [(message body meta-level feedback?)
(if (zero? meta-level) (if (zero? meta-level)
(transition (enqueue-event a w) '()) (transition (enqueue-event a w) '())
(transition w (message body (- meta-level 1) feedback?)))])) (transition w (message body (- meta-level 1) feedback?)))]))
(define (aggregate-routes base w) (define (aggregate-routes base w)
(apply append base (for/list ((p (in-hash-values (world-process-table w)))) (process-routes p)))) (apply append
base
(for/list ((g (in-hash-values (world-process-table w))))
(process-routes (trigger-guard-process g)))))
(define (issue-local-routing-update w) (define (issue-local-routing-update w)
(enqueue-event (routing-update (aggregate-routes (world-downward-routes w) w)) w)) (enqueue-event (routing-update (aggregate-routes (world-downward-routes w) w)) w))
@ -228,11 +252,18 @@
(routing-update (drop-routes (aggregate-routes '() w))))) (routing-update (drop-routes (aggregate-routes '() w)))))
(define (dispatch-event e w) (define (dispatch-event e w)
(for/fold ([w w]) (((pid p) (in-hash (world-process-table w)))) (for/fold ([w w]) (((pid g) (in-hash (world-process-table w))))
(match-define (trigger-guard p old-downward-rs) g)
(define e1 (filter-event e (process-routes p))) (define e1 (filter-event e (process-routes p)))
(if e1 (match e1
(apply-transition pid (deliver-event e1 pid p) w) [#f w]
w))) [(routing-update new-downward-rs)
(if (equal? old-downward-rs new-downward-rs)
w
(transform-process pid (apply-transition pid (deliver-event e1 pid p) w)
values
(lambda (old-rs) new-downward-rs)))]
[_ (apply-transition pid (deliver-event e1 pid p) w)])))
(define (world-handle-event e w) (define (world-handle-event e w)
(if (or e (not (quiescent? w))) (if (or e (not (quiescent? w)))