392 lines
15 KiB
Racket
392 lines
15 KiB
Racket
#lang racket/base
|
|
;; Virtualized operating system.
|
|
|
|
(require racket/match)
|
|
(require racket/list)
|
|
|
|
(provide
|
|
;; Waiting for messages
|
|
(struct-out suspension)
|
|
(struct-out message-handler)
|
|
|
|
;; Kernel requests
|
|
(struct-out kernel-mode-transition)
|
|
|
|
;; Constructing, accessing and running VMs
|
|
make-vm
|
|
vm?
|
|
run-vm
|
|
nested-vm
|
|
default-pattern-predicate
|
|
|
|
;; Grounding out the infinite tower of VMs
|
|
(struct-out ground-event-pattern)
|
|
(struct-out ground-event-value)
|
|
ground-vm
|
|
current-ground-transition ;; DEBUG
|
|
)
|
|
|
|
;; Each VM hosts 0 or more *multiplexed* processes. Each process has
|
|
;; its own state record. In between schedulings, a process consists of
|
|
;; its state and (effectively) a multicontinuation. The
|
|
;; multicontinuation is implemented as a collection of message
|
|
;; handlers, each of which is a pair of a message recogniser and a
|
|
;; procedure taking a message 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. The bus provides a pub/sub-like routing facility.
|
|
;;
|
|
;; 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 may (but currently do not) 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/. Since we have yet to address questions of failure here,
|
|
;; we treat timeout events as we do any other I/O facility.
|
|
|
|
;; VMs are parameterised over:
|
|
;; - the type of messages carried on the bus, Message
|
|
;; - the type of patterns over Messages, MessagePattern
|
|
;; - the type of messages to other VMs, MetaMessage
|
|
;; - the type of patterns over MetaMessages, MetaMessagePattern
|
|
|
|
;; VMs also come with algorithms that run MessagePatterns against
|
|
;; Messages (and MetaMessagePatterns against MetaMessages) in order to
|
|
;; decide whether they match or not:
|
|
;;
|
|
;; A PatternPredicate is a (MessagePattern Message -> Boolean), used
|
|
;; to match a message against a pattern. A MetaPatternPredicate is
|
|
;; similar, but for metamessages.
|
|
|
|
;; A VM is a (vm ListBagOf<Suspension>
|
|
;; ListOf<Message> ;; TODO: make unordered?
|
|
;; ListOf<MetaMessage> ;; TODO: make unordered?
|
|
;; ListOf<BootK>
|
|
;; PatternPredicate
|
|
;; MetaPatternPredicate).
|
|
(struct vm (suspensions
|
|
pending-messages
|
|
pending-meta-messages
|
|
pending-processes
|
|
pattern-predicate
|
|
meta-pattern-predicate) #: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), representing either a
|
|
;; fresh process or a previously-suspended process just about to
|
|
;; resume.
|
|
|
|
;; A Suspension is a
|
|
;; (suspension ProcessState
|
|
;; Maybe<InterruptK>
|
|
;; ListBagOf<MessageHandler>
|
|
;; ListBagOf<MetaMessageHandler>).
|
|
;; To poll the kernel, include a non-#f InterruptK.
|
|
(struct suspension (state
|
|
k
|
|
message-handlers
|
|
meta-message-handlers) #:transparent)
|
|
|
|
;; A MessageHandler is a (message-handler MessagePattern TrapK<Message>)
|
|
(struct message-handler (pattern k) #:transparent)
|
|
|
|
;; A KernelModeTransition is a
|
|
;; (kernel-mode-transition Suspension
|
|
;; ListBagOf<Message>
|
|
;; ListBagOf<MetaMessage>
|
|
;; ListBagOf<BootK>)
|
|
;; representing the suspension of the transitioning process, a list of
|
|
;; messages to emit at both this VM's and its container's level, and a
|
|
;; list of new processes to create and schedule.
|
|
(struct kernel-mode-transition (suspension
|
|
messages
|
|
meta-messages
|
|
new-processes) #:transparent)
|
|
|
|
;; A ListBagOf<X> is a ListOf<X> with the additional constraint that
|
|
;; order isn't meaningful.
|
|
|
|
;; BootK [#:pattern-predicate PatternPredicate] [#:meta-pattern-predicate MetaPatternPredicate]
|
|
;; -> VM
|
|
;; Constructs a generic VM layer. Optional arguments override the
|
|
;; default behaviour of using default-pattern-predicate for the two
|
|
;; VM-specific recognisers.
|
|
(define (make-vm boot
|
|
#:pattern-predicate [pattern-predicate default-pattern-predicate]
|
|
#:meta-pattern-predicate [meta-pattern-predicate default-pattern-predicate])
|
|
(vm (list)
|
|
(list)
|
|
(list)
|
|
(cons boot (list))
|
|
pattern-predicate
|
|
meta-pattern-predicate))
|
|
|
|
;; VM -> KernelModeTransition
|
|
;; (A kind of Meta-InterruptK.) Performs a once-around of the nested
|
|
;; processes held in this VM, dispatching events to them and
|
|
;; collecting events from them. Returns a KernelModeTransition that
|
|
;; lets this VM communicate with its container.
|
|
(define (run-vm state)
|
|
(let* ((state (requeue-pollers state))
|
|
(state (run-runnables state))
|
|
(state (dispatch-messages state))
|
|
(meta-messages (reverse (vm-pending-meta-messages state)))
|
|
(meta-handlers (append-map extract-downward-meta-message-handlers (vm-suspensions state)))
|
|
(poller-k (and (should-poll? state) run-vm)) ;; only block if there's nothing left to do
|
|
(state (struct-copy vm state [pending-meta-messages (list)])))
|
|
(kernel-mode-transition (suspension state poller-k meta-handlers '())
|
|
meta-messages
|
|
'()
|
|
'())))
|
|
|
|
;; VM -> VM
|
|
;; If any suspended processes were simply yielding to let others run
|
|
;; and to let outside events enter, put them back on the runlist.
|
|
(define (requeue-pollers state)
|
|
(foldl (lambda (susp state)
|
|
(if (suspension-polling? susp)
|
|
(enqueue-runnable (lambda () ((suspension-k susp) (suspension-state susp))) state)
|
|
(enqueue-suspension susp state)))
|
|
(struct-copy vm state [suspensions '()])
|
|
(vm-suspensions state)))
|
|
|
|
;; VM -> VM
|
|
;; Run each runnable process on the runlist, incorporating the
|
|
;; information from each of their KernelModeTransitions into our state
|
|
;; for the next go-around.
|
|
(define (run-runnables state)
|
|
(foldl (lambda (r state) (perform-transition (r) state))
|
|
(struct-copy vm state [pending-processes (list)])
|
|
(reverse (vm-pending-processes state))))
|
|
|
|
;; VM -> VM
|
|
;; Dispatch each queued-up message across our internal pub/sub network
|
|
;; to all listening parties. See match-suspension for semantics of
|
|
;; routing and delivery.
|
|
(define (dispatch-messages state)
|
|
(foldl dispatch-message
|
|
(struct-copy vm state [pending-messages (list)])
|
|
(reverse (vm-pending-messages state))))
|
|
|
|
;; Suspension -> ListOf<MetaMessageHandler>
|
|
;; Performs part of the level-shifting between a given VM and its
|
|
;; container: extracts all the meta-message-handlers from a given
|
|
;; suspension, converts them into *message* handlers for the VM below,
|
|
;; and returns them in a list.
|
|
(define (extract-downward-meta-message-handlers susp)
|
|
(for/list ([mmh (suspension-meta-message-handlers susp)])
|
|
(message-handler (message-handler-pattern mmh) dispatch-meta-message)))
|
|
|
|
;; MetaMessage -> VM -> KernelModeTransitions
|
|
;; (Which is to say, TrapK<MetaMessage> for VMs.) Handler invoked when
|
|
;; this VM's containing VM routes a message (at that level) to
|
|
;; us. Here we convert it to a *meta-message* and deliver it to
|
|
;; interested parties.
|
|
(define ((dispatch-meta-message message) state)
|
|
(run-vm
|
|
(foldl (match-suspension message
|
|
(vm-meta-pattern-predicate state)
|
|
suspension-meta-message-handlers)
|
|
(struct-copy vm state [suspensions '()])
|
|
(vm-suspensions state))))
|
|
|
|
;; KernelModeTransition VM -> VM
|
|
;; Extracts the subscriptions and actions from the given transition
|
|
;; and incorporates them into state.
|
|
(define (perform-transition transition state)
|
|
(match transition
|
|
[(kernel-mode-transition new-suspension
|
|
messages
|
|
meta-messages
|
|
new-processes)
|
|
(let* ((state (foldl enqueue-message state messages))
|
|
(state (foldl enqueue-runnable state new-processes))
|
|
(state (enqueue-suspension new-suspension state))
|
|
(state (foldl enqueue-meta-message state meta-messages)))
|
|
state)]
|
|
[other
|
|
(error 'vm "Processes must return a kernel-mode-transition struct; got ~v" other)]))
|
|
|
|
;; Message VM -> VM
|
|
;; Enqueues a message for later delivery over this VM's pub/sub bus.
|
|
(define (enqueue-message message state)
|
|
(struct-copy vm state [pending-messages (cons message (vm-pending-messages state))]))
|
|
|
|
;; BootK VM -> VM
|
|
;; Places a runnable process on the runlist.
|
|
(define (enqueue-runnable r state)
|
|
(struct-copy vm state [pending-processes (cons r (vm-pending-processes state))]))
|
|
|
|
;; Suspension VM -> VM
|
|
;; If the suspension is provably inert, discard it; otherwise, add it
|
|
;; to the collection of suspended processes in state. We currently
|
|
;; only have a conservative means of showing that a process is inert:
|
|
;; when it has no immediately-ready continuation, no message
|
|
;; subscriptions and no meta-message subscriptions, it is considered
|
|
;; inert here.
|
|
(define (enqueue-suspension susp state)
|
|
(match susp
|
|
[(suspension _ #f '() '())
|
|
;; dead process because no continuations offered
|
|
state]
|
|
[(suspension _ _ _ _)
|
|
(struct-copy vm state [suspensions (cons susp (vm-suspensions state))])]))
|
|
|
|
;; MetaMessage VM -> VM
|
|
;; Enqueues a metamessage for later delivery over this VM's pub/sub bus.
|
|
(define (enqueue-meta-message message state)
|
|
(struct-copy vm state [pending-meta-messages (cons message (vm-pending-meta-messages state))]))
|
|
|
|
;; Message VM -> VM
|
|
;; Routes a single Message to interested suspended processes, resuming
|
|
;; them as necessary. See match-suspension for semantics of routing
|
|
;; and delivery.
|
|
(define (dispatch-message message state)
|
|
(foldl (match-suspension message
|
|
(vm-pattern-predicate state)
|
|
suspension-message-handlers)
|
|
(struct-copy vm state [suspensions '()])
|
|
(vm-suspensions state)))
|
|
|
|
;; Message PatternPredicate (Suspension -> ListOf<MessageHandler>)
|
|
;; -> Suspension VM -> VM
|
|
;; Curried function. Uses handlers-getter to select either the
|
|
;; message-handlers or meta-message-handlers of susp, and walks
|
|
;; through them one at a time. If one matches the message, the message
|
|
;; is delivered to the process and none of the other handlers are
|
|
;; tried. Otherwise, if we end up with no handlers having matched, the
|
|
;; suspension is re-enqueued on the suspended process list of state.
|
|
(define ((match-suspension message apply-pattern handlers-getter) susp state)
|
|
(let search-handlers ((message-handlers (handlers-getter susp)))
|
|
(cond
|
|
[(null? message-handlers)
|
|
;; No handler matched this message. Put the suspension
|
|
;; back on the list for some future message.
|
|
(enqueue-suspension susp state)]
|
|
[(apply-pattern (message-handler-pattern (car message-handlers)) message)
|
|
(define trapk (message-handler-k (car message-handlers)))
|
|
(define interruptk (trapk message))
|
|
(perform-transition (interruptk (suspension-state susp)) state)]
|
|
[else
|
|
(search-handlers (cdr message-handlers))])))
|
|
|
|
;; Suspension -> Boolean
|
|
;; True iff the suspension can be immediately resumed without an external event.
|
|
(define (suspension-polling? susp)
|
|
(not (eq? (suspension-k susp) #f)))
|
|
|
|
;; VM -> Boolean
|
|
;; When should a VM block? When it has no runnables, no pending
|
|
;; messages, and no polling suspensions. Otherwise, it should poll.
|
|
(define (should-poll? state)
|
|
(or (not (null? (vm-pending-processes state)))
|
|
(not (null? (vm-pending-messages state)))
|
|
(ormap suspension-polling? (vm-suspensions state))))
|
|
|
|
;; BootK [#:pattern-predicate PatternPredicate] [#:meta-pattern-predicate MetaPatternPredicate]
|
|
;; -> BootK
|
|
;; Constructs a VM that will start with the passed-in BootK. Returns a
|
|
;; BootK representing the new VM, that is suitable for spawning as a
|
|
;; process in some containing VM. This is the glue between adjacent
|
|
;; layers in the tower.
|
|
(define (nested-vm boot
|
|
#:pattern-predicate [pattern-predicate default-pattern-predicate]
|
|
#:meta-pattern-predicate [meta-pattern-predicate default-pattern-predicate])
|
|
(lambda () (run-vm (make-vm boot
|
|
#:pattern-predicate pattern-predicate
|
|
#:meta-pattern-predicate meta-pattern-predicate))))
|
|
|
|
;; PatternPredicate (and also MetaPatternPredicate). The default
|
|
;; implementation: expects a MessagePattern (or MetaMessagePattern) to
|
|
;; be a predicate on a Message (or a MetaMessage).
|
|
(define default-pattern-predicate
|
|
(lambda (p m) (p m)))
|
|
|
|
;;---------------------------------------------------------------------------
|
|
|
|
;; Suspension -> Boolean
|
|
;; True iff provably inert. Uses a conservative definition of inertness.
|
|
(define (nested-vm-inert? susp)
|
|
(match susp
|
|
[(suspension (vm _ '() '() '() _ _) #f '() '())
|
|
;; Inert iff not waiting for any messages or metamessages, and
|
|
;; with no internal work left to do.
|
|
#t]
|
|
[_ #f]))
|
|
|
|
(struct ground-event-pattern (tag evt) #:transparent)
|
|
(struct ground-event-value (tag val) #:transparent)
|
|
|
|
(define (match-ground-event p m)
|
|
(equal? (ground-event-pattern-tag p) (ground-event-value-tag m)))
|
|
|
|
;; BootK [#:pattern-predicate PatternPredicate] -> Void
|
|
;;
|
|
;; Starts running (the lowest level of) a tower of VMs. This lowest
|
|
;; level has special support for routing metaevents to and from the
|
|
;; Racket event-handling and I/O mechanisms.
|
|
;;
|
|
;; In this context,
|
|
;; Message = a thunk
|
|
;; MessagePattern = evt?
|
|
;; MetaMessage, MetaMessagePattern = not defined because there's no outer level
|
|
;;
|
|
;; Runs a VM booted with the given BootK until the VM becomes
|
|
;; (provably) inert.
|
|
(define (ground-vm boot
|
|
#:pattern-predicate [pattern-predicate default-pattern-predicate])
|
|
(let loop ((transition (run-vm (make-vm boot
|
|
#:pattern-predicate pattern-predicate
|
|
#:meta-pattern-predicate match-ground-event))))
|
|
(set! current-ground-transition transition)
|
|
(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")]))))
|
|
|
|
;; For debugging
|
|
(define current-ground-transition #f)
|