Another step closer to a metacircular driver.

os.rkt

@@ -3,6 +3,7 @@
 ;; Virtualized operating system.
 
 (require racket/match)
+(require racket/list)
 (require "functional-queue.rkt")
 
 (provide ...)
@@ -48,53 +49,144 @@
 ;;  - the type of messages to other VMs, MetaMessage
 ;;  - the type of patterns over MetaMessages, MetaMessageEvent
 
-;; A VM is a (vm Map<Pid,Process>
-;;               QueueOf<Message>
-;;               QueueOf<InterruptK>).
-(struct vm (process-table pending-messages runnable) #:transparent)
+;; A VM is a (vm ListBagOf<Subscription>
+;;               QueueOf<Event>). ;; TODO: make unordered?
+(struct vm (subscriptions pending-events) #:transparent)
 
-;; A Pid is some eq?-comparable object, guaranteed to be unique within
-;; the scope of a single VM. It IDentifies a Process.
+;; A UserEvent is one of
+;; -- (message Message), a message emitted onto the bus
+;; -- (process BootK), a new sibling process to start
+(struct message (body) #:transparent)
+(struct process (boot) #:transparent)
 
-;; A Sid is some eq?-comparable object, guaranteed to be unique within
-;; the scope of a single VM's process. It IDentifies a Subscription.
+;; A KernelEvent is one of
+;; -- (meta-message MetaMessage), a message emitted onto the
+;; containing bus
+(struct meta-message (body) #:transparent)
 
-;; A Subscription is a (subscription Sid (Message -> Boolean) TrapK).
-(struct subscription (sid predicate handler) #:transparent)
+;; An Event is a UserEvent or a KernelEvent.
 
-;; An Action is one of
-;; -- (send-message Message), a message to emit onto the bus
-;; -- (spawn-process InterruptK), a new sibling process to start
-;; -- (subscribe sid 
+;; An EventHandler is an (event-handler Boolean (Event -> Boolean) TrapK<Event>)
+(struct event-handler (meta? matcher k) #:transparent)
 
-;; A TrapK is a Message -> InterruptK, representing a suspended
-;; process waiting for some information from the VM before it can
-;; continue.
+;; A TrapK<X> is a X -> InterruptK, representing a suspended process
+;; waiting for some information from the VM before it can continue.
 
 ;; An InterruptK is a
-;;                        ProcessState SetOf<Subscription>
-;;     -> ListOf<Message> ProcessState SetOf<Subscription> ListOf<InterruptK>
-;;
+;;   ProcessState -> KernelModeTransition
 ;; representing a suspended process that can run instantly without
-;; waiting for more information from the VM. The inputs are the state
-;; of the process and its current set of subscriptions, and the
-;; outputs are a list of messages to emit into the VM's communication
-;; bus, as well as possibly-updated process state and subscription
-;; list, and a list of new processes to spawn.
+;; waiting for more information from the VM. The input is the state of
+;; the process, and the output is the information passed back to the
+;; VM when the process yields the CPU.
+
+;; A BootK is a (Void -> KernelModeTransition), effectively an
+;; InterruptK with a void initial process state.
+
+;; A KernelModeTransition is a
+;; (kernel-mode-transition ProcessState
+;;                         ListBagOf<Event>
+;;			   ListBagOf<EventHandler>)
+;; representing a new process state, a list of events to emit and a
+;; list of events to wait for before resuming the process taking the
+;; transition.
+(struct kernel-mode-transition (state
+				events
+				event-handlers) #:transparent)
+
+;; A ListBagOf<X> is a ListOf<X> with the additional constraint that
+;; order isn't meaningful.
+
+;; A Subscription is a (subscription ProcessState ListBagOf<EventHandler>).
+(struct subscription (state event-handlers) #:transparent)
+
+;; TODO: is timeout really primitive? If so, isn't presence primitive?
+;; TODO: what about metatimeout?
+;; TODO: what about spawn-meta-process etc? Come back to this later.
+
+;; TODO: enforce user-mode restrictions
+
+;; TODO: timeouts
 
 (define (make-vm boot)
-  (vm (hash)
-      (make-queue)
-      (enqueue (make-queue) boot)))
+  (boot-process boot (vm (list) (make-queue) (make-queue))))
 
-;; VM SetOf<MetaSubscription> -> ListOf<MetaMessage> VM SetOf<MetaSubscription>
+(define (subscribe-process process-state event-handlers state)
+  (struct-copy vm state [subscriptions (cons (subscription process-state
+							   event-handlers)
+					     (vm-subscriptions state))]))
+
+(define (enqueue-event event state)
+  (struct-copy vm state [pending-events (cons event (vm-pending-events state))]))
+
+;; VM -> KernelModeTransition
 ;; (A kind of Meta-InterruptK)
-(define (run-vm state meta-subscriptions)
-  (define state-after-dispatch
-    (foldl dispatch-message
-	   (struct-copy vm state [pending-messages (make-queue)])
-	   (vm-pending-messages state)))
-  (define state-after-run
-    (foldl run-process
-	   (struct-copy vm state [runnable (make-queue)])
-	   (vm-runnable state)))
+(define (run-vm state)
+  (define state-after-timeouts state) ;; TODO
+  (define state-after-events
+    (foldl dispatch-event
+	   (struct-copy vm state-after-timeouts [pending-events (make-queue)])
+	   (vm-pending-events state)))
+  (trap-to-metalevel state-after-events))
+
+(define (dispatch-event event state)
+  (foldl (match-subscription event)
+	 (struct-copy vm state [subscriptions '()])
+	 (vm-subscriptions state)))
+
+(define ((match-subscription event) sub state)
+  (let search-handlers ((event-handlers (subscription-event-handlers sub)))
+    (cond
+     [(null? event-handlers)
+      ;; No handler matched this event. Put the subscription
+      ;; back on the list for some future event.
+      (struct-copy vm state [subscriptions (cons sub (vm-subscriptions state))])]
+     [((event-handler-matcher (car event-handlers)) event)
+      (run-process (subscription-state sub)
+		   (event-handler-k (car event-handlers))
+		   state)]
+     [else
+      (search-handlers (cdr event-handlers))])))
+
+(define (boot-process k state)
+  (run-process (void) k state))
+
+(define (run-process process-state k state)
+  (match (k process-state)
+    [(kernel-mode-transition new-process-state
+			     outbound-events
+			     new-event-handlers)
+     (subscribe-process new-process-state
+			new-event-handlers
+			(foldl enqueue-event state outbound-events))]))
+
+(define (trap-to-metalevel state)
+  (define-values (meta-messages non-meta-messages)
+    (partition meta-message? (vm-pending-events state)))
+  (define-values (processes remainder)
+    (partition process? non-meta-messages))
+  (define-values (messages junk)
+    (partition message? remainder))
+  (define final-state
+    (struct-copy vm (foldl (lambda (p state) (boot-process (process-boot p) state))
+			   state
+			   processes)
+		 [pending-events messages]))
+  (define outbound-meta-messages 
+    (map (lambda (mm) (message (meta-message-body mm))) meta-messages))
+  (kernel-mode-transition
+   final-state
+   (if (null? messages) ;; only block if there are no messages left to process
+       outbound-meta-messages
+       (cons (process (lambda (dummy) run-vm)) outbound-meta-messages))
+   (append-map (lambda (sub)
+		 (map rewrite-event-handler
+		      (filter event-handler-meta? (subscription-event-handlers sub))))
+	       (vm-subscriptions final-state))))
+
+(define (rewrite-event-handler eh)
+  (event-handler #f ;; we rewrite a handler of metaevents to a meta handler of events
+		 (event-handler-matcher eh)
+		 inject-meta-event))
+
+(define ((inject-meta-event e) state)
+  (run-vm (enqueue-event (meta-message e) state)))