diff --git a/prospect/core.rkt b/prospect/core.rkt index 9068675..4668fea 100644 --- a/prospect/core.rkt +++ b/prospect/core.rkt @@ -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 ]) (except-out (struct-out spawn) spawn) (rename-out [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 '())) diff --git a/prospect/demand-matcher.rkt b/prospect/demand-matcher.rkt index d040366..8adcf74 100644 --- a/prospect/demand-matcher.rkt +++ b/prospect/demand-matcher.rkt @@ -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)) diff --git a/prospect/drivers/udp.rkt b/prospect/drivers/udp.rkt index 6c2dcbd..5133723 100644 --- a/prospect/drivers/udp.rkt +++ b/prospect/drivers/udp.rkt @@ -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)) diff --git a/prospect/examples/example-lang.rkt b/prospect/examples/example-lang.rkt index b542d30..968c233 100644 --- a/prospect/examples/example-lang.rkt +++ b/prospect/examples/example-lang.rkt @@ -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) diff --git a/prospect/examples/example-plain.rkt b/prospect/examples/example-plain.rkt index 862c69e..8365e89 100644 --- a/prospect/examples/example-plain.rkt +++ b/prospect/examples/example-plain.rkt @@ -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) diff --git a/prospect/examples/udp-hello-plain.rkt b/prospect/examples/udp-hello-plain.rkt index 3f5186a..0be375a 100644 --- a/prospect/examples/udp-hello-plain.rkt +++ b/prospect/examples/udp-hello-plain.rkt @@ -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))) diff --git a/prospect/patch.rkt b/prospect/patch.rkt index fccffcd..9004319 100644 --- a/prospect/patch.rkt +++ b/prospect/patch.rkt @@ -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))) diff --git a/prospect/route.rkt b/prospect/route.rkt index 32e8294..e86cf17 100644 --- a/prospect/route.rkt +++ b/prospect/route.rkt @@ -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. diff --git a/prospect/trace/stderr.rkt b/prospect/trace/stderr.rkt index dd76e0d..9d43ea1 100644 --- a/prospect/trace/stderr.rkt +++ b/prospect/trace/stderr.rkt @@ -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)]