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

Much improved quit/transition protocol.

This commit is contained in:
Tony Garnock-Jones 2015-03-06 11:21:50 +00:00
parent 9f631e6143
commit 98bfbef056
9 changed files with 78 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
prospect/core.rkt
View File

@ -2,7 +2,8 @@
;; Core implementation of Incremental Network Calculus.
(provide (struct-out message)
(struct-out quit)
(except-out (struct-out quit) quit)
(rename-out [quit <quit>])
(except-out (struct-out spawn) spawn)
(rename-out [spawn <spawn>])
(struct-out process)
@ -36,6 +37,7 @@
pub
unpub
(rename-out [make-quit quit])
make-world
spawn-world
(rename-out [spawn-process spawn])
@ -57,7 +59,6 @@
(struct message (body) #:prefab)
;; Actions ⊃ Events
(struct quit () #:prefab)
(struct spawn (boot) #:prefab)
;; Processes (machine states): (process Matcher (Option Behavior) Any)
@ -73,14 +74,19 @@
;; - a (transition Any (Constreeof Action)), a new Process state to
;; be held by its World and a sequence of Actions for the World
;; to take on the transitioning Process's behalf.
;; - a (quit (Constreeof Action)), signalling that the Process should
;; never again be handed an event, and that any queued actions
;; should be performed, followed by the sequence of Actions given,
;; and then the process should be garbage-collected.
(struct transition (state actions) #:transparent)
(struct quit (actions) #:prefab)
;; A PID is a Nat.
;; A Label is a PID or 'meta.
;; VM private states
(struct world (next-pid ;; PID
pending-action-queue ;; (Queueof (Cons Label Action))
pending-action-queue ;; (Queueof (Cons Label (U Action 'quit)))
runnable-pids ;; (Setof PID)
routing-table ;; (Matcherof (Setof Label))
process-table ;; (HashTable PID Process)
@ -90,7 +96,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (event? x) (or (patch? x) (message? x)))
(define (action? x) (or (event? x) (spawn? x) (quit? x)))
(define (action? x) (or (event? x) (spawn? x)))
(define (meta-label? x) (eq? x 'meta))
@ -122,13 +128,16 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (ensure-transition v)
(if (or (not v) (transition? v))
(if (or (not v) (transition? v) (quit? v))
v
(raise (exn:fail:contract (format "Expected transition (or #f); got ~v" v)
(raise (exn:fail:contract (format "Expected transition, quit or #f; got ~v" v)
(current-continuation-marks)))))
(define (clean-transition t)
(and t (transition (transition-state t) (clean-actions (transition-actions t)))))
(match t
[#f #f]
[(quit actions) (quit (clean-actions actions))]
[(transition state actions) (transition state (clean-actions actions))]))
(define (clean-actions actions)
(filter (lambda (x) (and (action? x) (not (patch-empty? x)))) (flatten actions)))
@ -142,6 +151,10 @@
(lambda () (clean-transition (ensure-transition (behavior e old-state))))
(match-lambda
[#f w]
[(and q (quit final-actions))
(trace-process-step e pid p #f q)
(enqueue-actions (disable-process pid #f w) pid (append final-actions
(list 'quit)))]
[(and t (transition new-state new-actions))
(trace-process-step e pid p #f t)
(update-process pid
@ -150,7 +163,7 @@
w)])
(lambda (exn)
(trace-process-step e pid p exn #f)
(enqueue-actions (disable-process pid exn w) pid (list (quit)))))]))
(enqueue-actions (disable-process pid exn w) pid (list 'quit))))]))
(define (send-event/guard delta pid w)
(if (patch-empty? delta)
@ -158,7 +171,10 @@
(send-event delta pid w)))
(define (disable-process pid exn w)
(log-error "Process ~a died with exception:\n~a" (cons pid (trace-pid-stack)) (exn->string exn))
(when exn
(log-error "Process ~a died with exception:\n~a"
(cons pid (trace-pid-stack))
(exn->string exn)))
(match (hash-ref (world-process-table w) pid #f)
[#f w]
[old-p
@ -190,6 +206,9 @@
(queue-append-list (world-pending-action-queue w)
(for/list [(a actions)] (cons label a)))]))
(define (make-quit . actions)
(quit actions))
(define-syntax-rule (spawn-process behavior-exp initial-state-exp initial-patch-exp ...)
(spawn (lambda (pid)
(process (apply-patch (matcher-empty)
@ -215,10 +234,14 @@
(make-world (boot-actions-thunk))))))
(define (transition-bind k t0)
(match-define (transition state0 actions0) t0)
(match (k state0)
[#f t0]
[(transition state1 actions1) (transition state1 (cons actions0 actions1))]))
(match t0
[#f (error 'transition-bind "Cannot bind from transition #f with continuation ~v" k)]
[(quit _) t0]
[(transition state0 actions0)
(match (k state0)
[#f t0]
[(quit actions1) (quit (cons actions0 actions1))]
[(transition state1 actions1) (transition state1 (cons actions0 actions1))])]))
(define (sequence-transitions t0 . steps)
(foldl transition-bind t0 steps))
@ -274,7 +297,7 @@
(trace-pid-stack)
(exn->string exn))
(transition w '())))]
[(quit)
['quit
(define pt (world-process-table w))
(match (hash-ref pt label #f)
[#f (transition w '())]
@ -374,6 +397,7 @@
(pretty-print w)
(match (world-handle-event #f w)
[#f (values w (flatten actions))]
[(quit new-actions) (values w (flatten (cons actions new-actions)))]
[(transition new-w new-actions) (loop new-w (cons actions new-actions))])))
(step* (make-world '()))

6
prospect/demand-matcher.rkt
View File

@ -134,9 +134,11 @@
(define maybe-spawn (apply check-and-maybe-spawn-fn
new-aggregate
projection-results))
(transition new-aggregate (when maybe-spawn (list maybe-spawn (quit))))]
(if maybe-spawn
(quit maybe-spawn)
(transition new-aggregate '()))]
[(message (timer-expired (== timer-id) _))
(transition current-aggregate (list (timeout-handler) (quit)))]
(quit (timeout-handler))]
[_ #f]))
(matcher-empty)
(patch base-interests (matcher-empty))

2
prospect/drivers/udp.rkt
View File

@ -61,7 +61,7 @@
[(? patch? p)
(cond [(matcher-empty? (patch-removed p)) #f] ;; peer hasn't quit yet: do nothing.
[else (channel-put control-ch 'quit)
(transition s (quit))])]
(quit)])]
[(message (at-meta (? udp-packet? p)))
(transition s (message p))]
[(message (udp-packet _ (udp-remote-address host port) body))

8
prospect/examples/example-lang.rkt
View File

@ -33,7 +33,7 @@
(define (echoer e s)
(match e
[(message (at-meta (external-event _ (list (? eof-object?)))))
(transition s (quit))]
(quit)]
[(message (at-meta (external-event _ (list line))))
(transition s (message `(print (got-line ,line))))]
[_ #f]))
@ -49,9 +49,9 @@
#f]
[(message (timer-expired 'tick now))
(printf "TICK ~v\n" now)
(transition (+ s 1) (if (< s 3)
(message (set-timer 'tick 1000 'relative))
(quit)))]
(if (< s 3)
(transition (+ s 1) (message (set-timer 'tick 1000 'relative)))
(quit))]
[_ #f]))
(spawn-timer-driver)

8
prospect/examples/example-plain.rkt
View File

@ -31,7 +31,7 @@
(define (echoer e s)
(match e
[(message (at-meta (external-event _ (list (? eof-object?)))))
(transition s (quit))]
(quit)]
[(message (at-meta (external-event _ (list line))))
(transition s (message `(print (got-line ,line))))]
[_ #f]))
@ -44,9 +44,9 @@
#f]
[(message (timer-expired 'tick now))
(printf "TICK ~v\n" now)
(transition (+ s 1) (if (< s 3)
(message (set-timer 'tick 1000 'relative))
(quit)))]
(if (< s 3)
(transition (+ s 1) (message (set-timer 'tick 1000 'relative)))
(quit))]
[_ #f]))
(define (printer e s)

2
prospect/examples/udp-hello-plain.rkt
View File

@ -8,7 +8,7 @@
(match e
[(message (udp-packet src dst #"quit\n"))
(log-info "Got quit request")
(transition s (list (message (udp-packet dst src #"Goodbye!\n")) (quit)))]
(quit (message (udp-packet dst src #"Goodbye!\n")))]
[(message (udp-packet src dst body))
(log-info "Got packet from ~v: ~v" src body)
(define reply (string->bytes/utf-8 (format "You said: ~a" body)))

10
prospect/patch.rkt
View File

@ -7,6 +7,8 @@
(struct-out advertise)
empty-patch
patch-empty?
patch-non-empty?
patch/removed?
lift-patch
drop-patch
strip-interests
@ -55,6 +57,14 @@
(matcher-empty? (patch-added p))
(matcher-empty? (patch-removed p))))
(define (patch-non-empty? p)
(and (patch? p)
(or (matcher-non-empty? (patch-added p))
(matcher-non-empty? (patch-removed p)))))
(define (patch/removed? p)
(and (patch? p) (matcher-non-empty? (patch-removed p))))
(define (lift-patch p)
(match-define (patch in out) p)
(patch (pattern->matcher #t (at-meta (embedded-matcher in)))

12
prospect/route.rkt
View File

@ -20,10 +20,12 @@
matcher? ;; expensive; see implementation
matcher-empty
matcher-empty?
matcher-non-empty?
pattern->matcher
pattern->matcher*
matcher-union
matcher-intersect
empty-set-guard
matcher-subtract-combiner
matcher-subtract
matcher-match-value
@ -144,6 +146,10 @@
;; True iff the argument is the empty matcher
(define (matcher-empty? r) (not r))
;; Matcher -> Boolean
;; True iff the argument is NOT the empty matcher
(define (matcher-non-empty? r) (not (matcher-empty? r)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Smart constructors & accessors
;;
@ -337,9 +343,11 @@
(lambda (h) #f)
(lambda (h) #f)))
(define (empty-set-guard s)
(if (set-empty? s) #f s))
(define (matcher-subtract-combiner s1 s2)
(define r (set-subtract s1 s2))
(if (set-empty? r) #f r))
(empty-set-guard (set-subtract s1 s2)))
;; Matcher Matcher -> Matcher
;; Removes re2's mappings from re1.

9
prospect/trace/stderr.rkt
View File

@ -122,8 +122,11 @@
(output "Process ~a died with exception:\n~a\n"
pidstr
(exn->string exn))))
(when (quit? t)
(with-color BRIGHT-RED
(output "Process ~a exited normally.\n" pidstr)))
(when (or relevant-exn? show-process-states-post?)
(when t
(when (transition? t)
(unless (boring-state? (transition-state t))
(when (not (equal? (process-state p) (transition-state t)))
(with-color YELLOW
@ -132,7 +135,7 @@
[('internal-step (list pids a old-w t))
(when t ;; inert worlds don't change interestingly
(define pidstr (format-pids pids))
(define new-w (transition-state t))
(define new-w (if (transition? t) (transition-state t) old-w))
(define old-processes (world-process-table old-w))
(define new-processes (world-process-table new-w))
(define newcount (hash-count new-processes))
@ -155,7 +158,7 @@
(unless (matcher-empty? interests)
(output "~a's initial interests:\n" newpidstr)
(pretty-print-matcher interests (current-error-port))))]
[(quit)
['quit
(when (or show-process-lifecycle? show-actions?)
(match (hash-ref old-processes (car pids) (lambda () #f))
[#f (void)]