212 lines
7.7 KiB
Racket
212 lines
7.7 KiB
Racket
#lang racket/base
|
|
|
|
;; Virtualized operating system.
|
|
|
|
(require racket/match)
|
|
(require racket/list)
|
|
(require "functional-queue.rkt")
|
|
|
|
(provide
|
|
;; Actions/Events
|
|
(struct-out message)
|
|
(struct-out process)
|
|
|
|
;; Kernel Events
|
|
(struct-out meta-message)
|
|
|
|
;; Event handlers and kernel requests
|
|
(struct-out event-handler)
|
|
(struct-out kernel-mode-transition)
|
|
|
|
;; VMs
|
|
make-vm
|
|
run-vm
|
|
)
|
|
|
|
;; Each VM hosts 0 or more *multiplexed* processes. Each process has
|
|
;; its own state record. In between schedulings, a process consists of
|
|
;; 1 or more event handlers. An event handler is a pair of an event
|
|
;; recogniser and a procedure taking an event and a process state to a
|
|
;; new process state.
|
|
;;
|
|
;; Each VM provides a *communication bus* for its processes to
|
|
;; use. The communication bus is the only form of IPC the VM provides.
|
|
;;
|
|
;; Some processes *relay* messages out from the VM to other
|
|
;; VMs. Because the "tree" of VMs so formed has to be a tree - See
|
|
;; Shivers & Might 2006 for a discussion of this - we gather together
|
|
;; all the interactions between the supervenient VM and its support VM
|
|
;; into a single channel of communication. The relaying processes are,
|
|
;; in effect, device-drivers, providing application-specific
|
|
;; communication services to other processes in the VM.
|
|
;;
|
|
;; We split processes into "user" processes, permitted only to spawn
|
|
;; other user processes and send messages on the VM's bus, and
|
|
;; "kernel" processes, permitted also to spawn other kernel processes
|
|
;; and send messages to the VM's container.
|
|
;;
|
|
;; Time plays an interesting role in a distributed system: if the
|
|
;; medium messages are sent through isn't cooperative enough to let us
|
|
;; know of a failed conversational participant, our only recourse is
|
|
;; /timeout/. Therefore, we require every level of the machine to
|
|
;; support timeouts, though we do not require such timeouts to be tied
|
|
;; to real, wall-clock time: simulated time is just fine. This helps
|
|
;; with testability.
|
|
;;
|
|
;; Racket's alarm-evt is almost the right design for timeouts: its
|
|
;; synchronisation value should be the (or some) value of the clock
|
|
;; after the asked-for time. That way it serves as timeout and
|
|
;; clock-reader in one.
|
|
|
|
;; VMs are parameterised over:
|
|
;; - the type of messages carried on the bus, Message
|
|
;; - the type of patterns over Messages, MessageEvent
|
|
;; - the type of messages to other VMs, MetaMessage
|
|
;; - the type of patterns over MetaMessages, MetaMessageEvent
|
|
|
|
;; A VM is a (vm ListBagOf<Subscription>
|
|
;; QueueOf<Event>). ;; TODO: make unordered?
|
|
(struct vm (subscriptions pending-events) #:transparent)
|
|
|
|
;; 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 KernelEvent is one of
|
|
;; -- (meta-message MetaMessage), a message emitted onto the
|
|
;; containing bus
|
|
(struct meta-message (body) #:transparent)
|
|
|
|
;; An Event is a UserEvent or a KernelEvent.
|
|
|
|
;; An EventHandler is an (event-handler Boolean (Event -> Boolean) TrapK<Event>)
|
|
(struct event-handler (meta? matcher k) #:transparent)
|
|
|
|
;; 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 -> KernelModeTransition
|
|
;; representing a suspended process that can run instantly without
|
|
;; 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 ( -> 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)
|
|
(boot-process boot (vm (list) (make-queue))))
|
|
|
|
(define (subscribe-process process-state event-handlers state)
|
|
(if (null? event-handlers)
|
|
state ;; dead process because no continuations offered
|
|
(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)
|
|
(define state-after-timeouts state) ;; TODO
|
|
(define state-after-events
|
|
(foldl dispatch-event
|
|
(struct-copy vm state-after-timeouts [pending-events (make-queue)])
|
|
(queue->list (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) (lambda (dummy) (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))]
|
|
[other
|
|
(error 'vm "Processes must return a kernel-mode-transition struct; got ~v" other)]))
|
|
|
|
(define (trap-to-metalevel state)
|
|
(define-values (meta-messages non-meta-messages)
|
|
(partition meta-message? (queue->list (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 (list->queue 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)))
|