Fix metamessage dispatch

os.rkt

@@ -70,21 +70,18 @@
 ;;  - the type of messages to other VMs, MetaMessage
 ;;  - the type of patterns over MetaMessages, MetaMessagePattern
 
-;; A VTable is a (vtable (MessagePattern Message -> Boolean)
-;;                       (MetaMessagePattern MetaMessage -> boolean))
-;; supplying the behavioural aspects of the type-parameters of VMs.
-(struct vtable (apply-message-pattern
-		apply-meta-message-pattern) #:transparent)
+;; A PatternPredicate is a (MessagePattern Message -> Boolean), used
+;; to match a message against a pattern.
 
-;; A VM is a (vm ListBagOf<Subscription>
+;; A VM is a (vm ListBagOf<Suspension>
 ;;               QueueOf<Message> ;; TODO: make unordered?
 ;;               QueueOf<MetaMessage> ;; TODO: make unordered?
 ;;               QueueOf<Runnable>).
-(struct vm (subscriptions
+(struct vm (suspensions
 	    pending-messages
 	    pending-meta-messages
 	    pending-processes
-	    vtable) #:transparent)
+	    pattern-predicate) #:transparent)
 
 ;; A TrapK<X> is a X -> InterruptK, representing a suspended process
 ;; waiting for some information from the VM before it can continue.
@@ -111,6 +108,21 @@
 		      message-handlers
 		      meta-message-handlers) #:transparent)
 
+;; A Suspension is a
+;; (suspension ProcessState
+;;             Maybe<InterruptK>
+;;             ListBagOf<MessageHandler>
+;;             Map<HID,MetaMessageHandler>).
+(struct suspension (state
+		    k
+		    message-handlers
+		    meta-message-handlers) #:transparent)
+
+;; A HID is a per-VM unique value, used to identify specific
+;; MetaMessageHandlers. Here, we use gensyms, though an alternative
+;; (and purer) approach would be to keep a counter in the VM and use
+;; that to construct IDs.
+
 ;; A MessageHandler is one of
 ;; -- (message-handler MessagePattern TrapK<Message>)
 (struct message-handler (pattern k) #:transparent)
@@ -137,13 +149,13 @@
 ;; TODO: enforce user-mode restrictions
 ;; TODO: timeouts
 
-;; ( -> KernelModeTransition ) -> VM
-(define (make-vm vtable boot)
+;; PatternPredicate ( -> KernelModeTransition ) -> VM
+(define (make-vm pattern-predicate boot)
   (vm (list)
       (make-queue)
       (make-queue)
       (enqueue (make-queue) (runnable (void) (lambda (dummy) (boot))))
-      vtable))
+      pattern-predicate))
 
 ;; VM -> KernelModeTransition
 ;; (A kind of Meta-InterruptK)
@@ -155,14 +167,14 @@
     (trap-to-metalevel state)))
 
 (define (requeue-pollers state)
-  (foldl (lambda (sub state)
-	   (if (subscription-polling? sub)
-	       (enqueue-runnable (runnable (subscription-state sub)
-					   (subscription-k sub))
+  (foldl (lambda (susp state)
+	   (if (suspension-polling? susp)
+	       (enqueue-runnable (runnable (suspension-state susp)
+					   (suspension-k susp))
 				 state)
-	       (subscribe-process sub state)))
-	 (struct-copy vm state [subscriptions '()])
-	 (vm-subscriptions state)))
+	       (enqueue-suspension susp state)))
+	 (struct-copy vm state [suspensions '()])
+	 (vm-suspensions state)))
 
 (define (run-runnables state)
   (foldl (lambda (r state)
@@ -178,7 +190,6 @@
 
 ;; KernelModeTransition VM -> VM
 (define (perform-transition transition state)
-  (pretty-print `(--> perform-transition ,transition ,state))
   (match transition
     [(kernel-mode-transition new-subscription
 			     messages
@@ -186,70 +197,69 @@
 			     new-processes)
      (let* ((state (foldl enqueue-message state messages))
 	    (state (foldl enqueue-runnable state new-processes))
-	    (state (subscribe-process new-subscription state))
+	    (state (enqueue-suspension (subscription->suspension new-subscription) state))
 	    (state (foldl enqueue-meta-message state meta-messages)))
-       (pretty-print `(<-- ,state))
        state)]
     [other
      (error 'vm "Processes must return a kernel-mode-transition struct; got ~v" other)]))
 
+(define (subscription->suspension sub)
+  (match-define (subscription ps k mhs mmhs) sub)
+  (suspension ps k mhs (for/hash ([mmh mmhs]) (values (gensym 'hid) mmh))))
+
 (define (enqueue-message message state)
   (struct-copy vm state [pending-messages (enqueue (vm-pending-messages state) message)]))
 
 (define (enqueue-runnable r state)
   (struct-copy vm state [pending-processes (enqueue (vm-pending-processes state) r)]))
 
-(define (subscribe-process sub state)
-  (match sub
-    [(subscription _ #f '() '())
+(define (enqueue-suspension susp state)
+  (match susp
+    [(suspension _ #f '() (? (lambda (h) (zero? (hash-count h)))))
      ;; dead process because no continuations offered
      state]
-    [_
-     (struct-copy vm state [subscriptions (cons sub (vm-subscriptions state))])]))
+    [(suspension _ _ _ _)
+     (struct-copy vm state [suspensions (cons susp (vm-suspensions state))])]))
 
 (define (enqueue-meta-message message state)
   (struct-copy vm state [pending-meta-messages (enqueue (vm-pending-meta-messages state) message)]))
 
 (define (dispatch-message message state)
-  (foldl (match-subscription message
-			     vtable-apply-message-pattern
-			     subscription-message-handlers)
-	 (struct-copy vm state [subscriptions '()])
-	 (vm-subscriptions state)))
+  (foldl (match-suspension message
+			     (vm-pattern-predicate state)
+			     suspension-message-handlers)
+	 (struct-copy vm state [suspensions '()])
+	 (vm-suspensions state)))
 
-(define ((match-subscription message apply-getter handlers-getter) sub state)
-  (let search-handlers ((message-handlers (handlers-getter sub)))
+(define ((match-suspension message apply-pattern handlers-getter) susp state)
+  (let search-handlers ((message-handlers (handlers-getter susp)))
     (cond
      [(null? message-handlers)
-      ;; No handler matched this message. Put the subscription
+      ;; No handler matched this message. Put the suspension
       ;; back on the list for some future message.
-      (subscribe-process sub state)]
-     [((apply-getter (vm-vtable state))
-       (message-handler-pattern (car message-handlers))
-       message)
+      (enqueue-suspension susp state)]
+     [(apply-pattern (message-handler-pattern (car message-handlers)) message)
       (define trapk (message-handler-k (car message-handlers)))
       (define interruptk (trapk message))
-      (perform-transition (interruptk (subscription-state sub)) state)]
+      (perform-transition (interruptk (suspension-state susp)) state)]
      [else
       (search-handlers (cdr message-handlers))])))
 
-(define (subscription-polling? sub)
-  (not (eq? (subscription-k sub) #f)))
+(define (suspension-polling? susp)
+  (not (eq? (suspension-k susp) #f)))
 
 ;; VM -> Boolean
 ;; When should a VM block? When it has no runnables, no pending
-;; messages, and no polling subscriptions. Otherwise, it should poll.
+;; messages, and no polling suspensions. Otherwise, it should poll.
 (define (should-poll? state)
   (or (not (queue-empty? (vm-pending-processes state)))
       (not (queue-empty? (vm-pending-messages state)))
-      (ormap subscription-polling? (vm-subscriptions state))))
+      (ormap suspension-polling? (vm-suspensions state))))
 
 (define (trap-to-metalevel state)
   (define meta-messages (queue->list (vm-pending-meta-messages state)))
-  (define meta-handlers (append-map (lambda (sub)
-				      (map wrap-meta-message-handler
-					   (subscription-meta-message-handlers sub)))
-				    (vm-subscriptions state)))
+  (define meta-handlers (append-map extract-downward-meta-message-handlers
+				    (vm-suspensions state)))
   (define final-state (struct-copy vm state [pending-meta-messages (make-queue)]))
   (kernel-mode-transition (subscription final-state
 					(and (should-poll? final-state)
@@ -261,16 +271,21 @@
 			  '()
 			  '()))
 
-(define (wrap-meta-message-handler mh)
-  (message-handler (message-handler-pattern mh) dispatch-meta-message))
+(define (extract-downward-meta-message-handlers susp)
+  (for/list ([(hid mmh) (in-hash (suspension-meta-message-handlers susp))])
+    (message-handler (message-handler-pattern mmh) (dispatch-meta-message hid))))
 
-(define ((dispatch-meta-message message) state)
+(define (extract-upward-meta-message-handlers susp)
+  (for/list ([(hid mmh) (in-hash (suspension-meta-message-handlers susp))])
+    (message-handler hid (message-handler-k mmh))))
+
+(define (((dispatch-meta-message hid) message) state)
   (run-vm
-   (foldl (match-subscription message
-			      vtable-apply-meta-message-pattern
-			      subscription-meta-message-handlers)
-	  (struct-copy vm state [subscriptions '()])
-	  (vm-subscriptions state))))
+   (foldl (match-suspension message
+			      (lambda (handler-hid message) (equal? hid handler-hid))
+			      extract-upward-meta-message-handlers)
+	  (struct-copy vm state [suspensions '()])
+	  (vm-suspensions state))))
 
 ;;---------------------------------------------------------------------------
 
@@ -293,16 +308,14 @@
      #t]
     [_ #f]))
 
-;; (MessagePattern Message -> Boolean) ( -> KernelModeTransition ) -> Void
+;; PatternPredicate ( -> KernelModeTransition ) -> Void
 ;; In this context,
 ;;   Message = a thunk
 ;;   MessagePattern = evt?
 ;;   MetaMessage, MetaMessagePattern = not defined because there's no outer level
 ;; Runs its argument VM until it becomes (provably) inert.
-(define (ground-vm apply-message-pattern boot)
-  (let loop ((transition (run-vm (make-vm (vtable apply-message-pattern
-						  match-ground-message)
-					  boot))))
+(define (ground-vm pattern-predicate boot)
+  (let loop ((transition (run-vm (make-vm pattern-predicate boot))))
     (when (not (nested-vm-inert? transition))
       (match transition
 	[(kernel-mode-transition (subscription new-state
@@ -314,23 +327,15 @@
 				 '())
 	 (for-each (lambda (thunk) (thunk)) outbound-messages)
 	 (define inbound-messages
-	   (map (match-lambda [(message-handler e k) (wrap-evt e (lambda (v) (list v e k)))])
+	   (map (match-lambda [(message-handler e k) (wrap-evt e (lambda (v) (cons v k)))])
 		message-handlers))
-	 (match-define (cons inbound-value inbound-evt inbound-continuation)
-;;
-;; Plan: make the processes metatalking to the ground-vm supply unique
-;; identifiers, and use those unique identifiers for matching up the
-;; specific events with specific event handlers. So when a
-;; metamessagepattern is built, use some constructor procedure to
-;; build an opaque metamessagepattern containing a unique ID; and when
-;; the incoming event comes in, label it with the appropriate ID.
-;;
+	 (match-define (cons inbound-value inbound-continuation)
 	   (apply sync
 		  (wrap-evt (if polling-k always-evt never-evt)
 			    (lambda (v) (cons (void)
 					      (lambda (dummy) polling-k))))
 		  inbound-messages))
-	 (loop ((inbound-message-continuation inbound-message-value) new-state))]
+	 (loop ((inbound-continuation inbound-value) new-state))]
 	[_
 	 (error 'ground-vm
 		"Outermost VM may not spawn new siblings or send or receive metamessages")]))))
@@ -360,16 +365,19 @@
 					'()
 					(list (message-handler
 					       (super-alarm (+ (current-inexact-milliseconds) n))
-					       (lambda (_) (k)))))
+					       (lambda (_message)
+						 (lambda (_state)
+						   (k))))))
 			  '()
 			  '()
 			  '()))
-(ground-vm #f ;; TODO - fix this - what's a better way of correlating
-	      ;; metamessages with their metamessagepatterns??
+(ground-vm (lambda (p m) (p m))
 	   (lambda ()
-	     (sleep 1000
+	     (print "SLEEPING"
 		    (lambda ()
-		      (yield
-		       (lambda ()
-			 (print "HELLO"
-				quit)))))))
+		      (sleep 2000
+			     (lambda ()
+			       (yield
+				(lambda ()
+				  (print "HELLO"
+					 quit)))))))))