WIP toward ground-vm

os2.rkt

@@ -280,3 +280,67 @@
     [(? send-message?) preaction]
     [(spawn thunk k)
      (spawn thunk (wrap-trapk pid k))]))
+
+;;---------------------------------------------------------------------------
+
+(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)
+
+	    (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")])))