diff --git a/os.rkt b/os.rkt index 6da69f4..8f720d8 100644 --- a/os.rkt +++ b/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 -;; QueueOf -;; QueueOf). -(struct vm (process-table pending-messages runnable) #:transparent) +;; A VM is a (vm ListBagOf +;; QueueOf). ;; 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) +(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 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 -;; -> ListOf ProcessState SetOf ListOf -;; +;; 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 +;; ListBagOf) +;; 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 is a ListOf with the additional constraint that +;; order isn't meaningful. + +;; A Subscription is a (subscription ProcessState ListBagOf). +(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 -> ListOf VM SetOf +(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)))