Implement ground-vm. It's so much smaller and nicer!

os2.rkt

@@ -144,6 +144,9 @@
 ;; QuasiQueue<X>
 (define empty-quasi-queue '())
 
+;; QuasiQueue<X> -> Boolean
+(define quasi-queue-empty? null?)
+
 ;; X QuasiQueue<X> -> QuasiQueue<X>
 (define (quasi-enqueue-one thing existing-quasi-queue)
   (cons thing existing-quasi-queue))
@@ -351,63 +354,29 @@
   (lambda () (run-vm (make-vm boot))))
 
 (define (ground-vm boot)
-  (let run-kernel ((transition (run-vm (make-vm boot)))
-		   (endpoints (hash))
-		   (next-eid-number 0))
-    (let integrate-delta ((state (transition-state transition))
-			  (actions (transition-actions transition))
-			  (endpoints endpoints)
-			  (next-eid-number 0))
-      (match actions
-	['()
-	 (define interruptk (apply sync
-				   (for/list ([(eid e) (in-hash events)])
-				     (wrap-evt (endpoint-topic e)
-					       (lambda (message)
-						 (run-user-code
-						  ((handlers-message (endpoint-handlers e))
-						   eid
-						   (endpoint-topic e)
-						   message)))))))
-	 (run-kernel (run-user-code (interruptk state)))]
-	[(cons preaction rest)
-	 (match preaction
-	   [(add-role topic hs k)
+  (let loop ((state (make-vm boot)))
+    (match (run-vm state)
+      [(transition state actions)
+       (when (not (null? actions))
+	 (error 'ground-vm "No meta-actions available in ground-vm: ~v" actions))
+       (define waiting? (quasi-queue-empty? (vm-pending-actions state)))
+       (define active-events (for/list ([(eid e) (in-hash (vm-endpoints state))]
+					#:when (eq? (topic-role (endpoint-topic e)) 'subscriber))
+			       (define evt (topic-pattern (endpoint-topic e)))
+			       (wrap-evt evt (lambda (message)
+					       (lambda (state)
+						 (route-and-deliver (topic-publisher evt)
+								    message
+								    state))))))
+       (if (and waiting? (null? active-events))
+	   ;; About to block, and nothing can wake us
+	   'done
+	   (let ((interruptk (apply sync
+				    (if waiting?
+					never-evt
+					(wrap-evt always-evt (lambda (dummy) values)))
+				    active-events)))
+	     (loop (interruptk state))))])))
 
-	    (integrate-delta (run-user-code
-						    ((run-user-code (k next-eid-number))
-						     state))
-							      
-rest
-						   (hash-set endpoints
-							     next-eid-number
-							     (endpoint next-eid-number
-
-	   [(delete-role eid reason) ...]
-	   [(send-message topic body) ...]
-	   [(spawn thunk k) ...])]))))
-
-    (for-each (lambda (thunk) (thunk)) (kernel-mode-transition-messages transition))
-    (when (not (nested-vm-inert? (kernel-mode-transition-suspension transition)))
-      (match transition
-	[(kernel-mode-transition (suspension new-state
-					     polling-k
-					     message-handlers
-					     '())
-				 _
-				 '()
-				 '())
-	 (define inbound-messages
-	   (map (match-lambda [(message-handler (ground-event-pattern tag evt) k)
-			       (wrap-evt evt (lambda (v) (cons (ground-event-value tag v) k)))])
-		message-handlers))
-	 (match-define (cons inbound-value inbound-continuation)
-	   (apply sync
-		  (wrap-evt (if polling-k always-evt never-evt)
-			    (lambda (v) (cons (ground-event-value 'idle (void))
-					      (lambda (dummy) polling-k))))
-		  inbound-messages))
-	 (loop ((inbound-continuation inbound-value) new-state))]
-	[_
-	 (error 'ground-vm
-		"Outermost VM may not spawn new siblings or send or receive metamessages")])))
+;;(require racket/trace)
+;;(trace perform-action)