Much improved quit/transition protocol.

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 <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 t0
-  (match (k state0)
+    [#f (error 'transition-bind "Cannot bind from transition #f with continuation ~v" k)]
-    [#f t0]
+    [(quit _) t0]
-    [(transition state1 actions1) (transition state1 (cons actions0 actions1))]))
+    [(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 '()))

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))

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))

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)
+     (if (< s 3)
-			     (message (set-timer 'tick 1000 'relative))
+         (transition (+ s 1) (message (set-timer 'tick 1000 'relative)))
-			     (quit)))]
+         (quit))]
     [_ #f]))
 
 (spawn-timer-driver)

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)
+     (if (< s 3)
-			     (message (set-timer 'tick 1000 'relative))
+         (transition (+ s 1) (message (set-timer 'tick 1000 'relative)))
-			     (quit)))]
+         (quit))]
     [_ #f]))
 
 (define (printer e s)

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)))

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)))

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))
+  (empty-set-guard (set-subtract s1 s2)))
-  (if (set-empty? r) #f r))
 
 ;; Matcher Matcher -> Matcher
 ;; Removes re2's mappings from re1.

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)]