syndicate-lang
/
racket-dns-2012
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Almost there!

This commit is contained in:
Tony Garnock-Jones 2012-01-09 18:19:44 -05:00
parent 82229e28f1
commit ad20706194
1 changed files with 272 additions and 118 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

390
os.rkt
View File

@ -1,5 +1,7 @@
#lang racket/base
(require racket/pretty)
;; Virtualized operating system.
(require racket/match)
@ -7,26 +9,30 @@
(require "functional-queue.rkt")
(provide
;; Actions/Events
(struct-out message)
(struct-out process)
;; Spawning processes
(struct-out runnable)
;; Kernel Events
(struct-out meta-message)
;; Waiting for messages
(struct-out subscription)
(struct-out message-handler)
;; Event handlers and kernel requests
(struct-out event-handler)
;; Kernel requests
(struct-out kernel-mode-transition)
;; VMs
;; Constructing, accessing and running VMs
make-vm
vm?
run-vm
)
;; Grounding out the infinite tower of VMs
nested-vm-inert?
ground-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
;; 1 or more message handlers. A message handler 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
@ -60,29 +66,25 @@
;; VMs are parameterised over:
;; - the type of messages carried on the bus, Message
;; - the type of patterns over Messages, MessageEvent
;; - the type of patterns over Messages, MessagePattern
;; - the type of messages to other VMs, MetaMessage
;; - the type of patterns over MetaMessages, MetaMessageEvent
;; - the type of patterns over MetaMessages, MetaMessagePattern
;; A VTable is a (vtable (MessagePattern Message -> Boolean)
;; (MetaMessagePattern MetaMessage -> boolean))
;; supplying the behavioural aspects of the type-parameters of VMs.
(struct vtable (apply-message-pattern
apply-meta-message-pattern) #:transparent)
;; 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)
;; QueueOf<Message> ;; TODO: make unordered?
;; QueueOf<MetaMessage> ;; TODO: make unordered?
;; QueueOf<Runnable>).
(struct vm (subscriptions
pending-messages
pending-meta-messages
pending-processes
vtable) #:transparent)
;; A TrapK<X> is a X -> InterruptK, representing a suspended process
;; waiting for some information from the VM before it can continue.
@ -94,118 +96,270 @@
;; 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 Runnable is a (runnable ProcessState InterruptK), representing a
;; temporarily-suspended runnable process.
(struct runnable (state k) #:transparent)
;; A Subscription is a
;; (subscription ProcessState
;; Maybe<InterruptK>
;; ListBagOf<MessageHandler>
;; ListBagOf<MetaMessageHandler>).
;; To poll the kernel, include a non-#f InterruptK.
(struct subscription (state
k
message-handlers
meta-message-handlers) #:transparent)
;; A MessageHandler is one of
;; -- (message-handler MessagePattern TrapK<Message>)
(struct message-handler (matcher k) #:transparent)
;; 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)
;; (kernel-mode-transition Subscription
;; ListBagOf<Message>
;; ListBagOf<MetaMessage>
;; ListBagOf<Runnable>)
;; representing the subscription for 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 (subscription
messages
meta-messages
new-processes) #: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))]))
;; ( -> KernelModeTransition ) -> VM
(define (make-vm vtable boot)
(vm (list)
(make-queue)
(make-queue)
(enqueue (make-queue) (runnable (void) (lambda (dummy) (boot))))
vtable))
;; 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))
(pretty-print `(run-vm ,state))
(let* ((state (requeue-pollers state))
(state (run-runnables state))
(state (dispatch-messages state)))
(trap-to-metalevel state)))
(define (dispatch-event event state)
(foldl (match-subscription event)
(define (requeue-pollers state)
(foldl (lambda (sub state)
(if (subscription-polling? sub)
(enqueue-runnable (runnable (subscription-state sub)
(subscription-k sub))
state)
(subscribe-process sub state)))
(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 (run-runnables state)
(foldl (lambda (r state)
(match-define (runnable process-state k) r)
(perform-transition (k process-state) state))
(struct-copy vm state [pending-processes (make-queue)])
(queue->list (vm-pending-processes state))))
(define (boot-process k state)
(run-process (void) (lambda (dummy) (k)) state))
(define (dispatch-messages state)
(foldl dispatch-message
(struct-copy vm state [pending-messages (make-queue)])
(queue->list (vm-pending-messages 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))]
;; KernelModeTransition VM -> VM
(define (perform-transition transition state)
(pretty-print `(--> perform-transition ,transition ,state))
(match transition
[(kernel-mode-transition new-subscription
messages
meta-messages
new-processes)
(let* ((state (foldl enqueue-message state messages))
(state (foldl enqueue-runnable state new-processes))
(state (subscribe-process new-subscription state))
(state (foldl enqueue-meta-message state meta-messages)))
(pretty-print `(<-- ,state))
state)]
[other
(error 'vm "Processes must return a kernel-mode-transition struct; got ~v" other)]))
(define (enqueue-message message state)
(struct-copy vm state [pending-messages (enqueue (vm-pending-messages state) message)]))
(define (enqueue-runnable r state)
(struct-copy vm state [pending-processes (enqueue (vm-pending-processes state) r)]))
(define (subscribe-process sub state)
(match sub
[(subscription _ #f '() '())
;; dead process because no continuations offered
state]
[_
(struct-copy vm state [subscriptions (cons sub (vm-subscriptions state))])]))
(define (enqueue-meta-message message state)
(struct-copy vm state [pending-meta-messages (enqueue (vm-pending-meta-messages state) message)]))
(define (dispatch-message message state)
(foldl (match-subscription message
vtable-apply-message-pattern
subscription-message-handlers)
(struct-copy vm state [subscriptions '()])
(vm-subscriptions state)))
(define ((match-subscription message apply-getter handlers-getter) sub state)
(let search-handlers ((message-handlers (handlers-getter sub)))
(cond
[(null? message-handlers)
;; No handler matched this message. Put the subscription
;; back on the list for some future message.
(subscribe-process sub state)]
[((apply-getter (vm-vtable state))
(message-handler-matcher (car message-handlers))
message)
(perform-transition ((message-handler-k (car message-handlers))
(subscription-state sub))
state)]
[else
(search-handlers (cdr message-handlers))])))
(define (subscription-polling? sub)
(not (eq? (subscription-k sub) #f)))
;; VM -> Boolean
;; When should a VM block? When it has no runnables, no pending
;; messages, and no polling subscriptions. Otherwise, it should poll.
(define (should-poll? state)
(or (not (queue-empty? (vm-pending-processes state)))
(not (queue-empty? (vm-pending-messages state)))
(ormap subscription-polling? (vm-subscriptions state))))
(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 meta-messages (queue->list (vm-pending-meta-messages state)))
(define meta-handlers (append-map (lambda (sub)
(map wrap-meta-message-handler
(subscription-meta-message-handlers sub)))
(vm-subscriptions state)))
(define final-state (struct-copy vm state [pending-meta-messages (make-queue)]))
(kernel-mode-transition (subscription final-state
(and (should-poll? final-state)
;; only block if there's nothing left to do
run-vm)
meta-handlers
'())
meta-messages
'()
'()))
(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 (wrap-meta-message-handler mh)
(message-handler (message-handler-matcher mh) dispatch-meta-message))
(define ((inject-meta-event e) state)
(run-vm (enqueue-event (meta-message e) state)))
(define ((dispatch-meta-message message) state)
(run-vm
(foldl (match-subscription message
vtable-apply-meta-message-pattern
subscription-meta-message-handlers)
(struct-copy vm state [subscriptions '()])
(vm-subscriptions state))))
;;---------------------------------------------------------------------------
(define (nested-vm-inert? transition)
(match transition
[(kernel-mode-transition (subscription (vm _
(? queue-empty?)
(? queue-empty?)
(? queue-empty?)
_)
#f
'()
'())
_
_
'())
;; No pending-messages within the nested VM, so no internal
;; activity is possible, and furthermore it is not waiting for
;; any outside messages.
#t]
[_ #f]))
;; VTable ( -> KernelModeTransition ) -> Void
;; In this context,
;; Message = a thunk
;; MessagePattern = evt?
;; MetaMessage, MetaMessagePattern = not defined because there's no outer level
;; Runs its argument VM until it becomes (provably) inert.
(define (ground-vm vtable boot)
(let loop ((transition (run-vm (make-vm vtable boot))))
(when (not (nested-vm-inert? transition))
(match transition
[(kernel-mode-transition (subscription new-state
polling-k
message-handlers
'())
outbound-messages
'()
'())
(for-each (lambda (thunk) (thunk)) outbound-messages)
(define inbound-messages
(map (match-lambda [(message-handler e k) (wrap-evt e (lambda (v) (cons v k)))])
message-handlers))
(match-define (cons inbound-message-value inbound-message-continuation)
(apply sync
(wrap-evt (if polling-k always-evt never-evt)
(lambda (v) (cons (void)
(lambda (dummy) polling-k))))
inbound-messages))
(loop ((inbound-message-continuation inbound-message-value) new-state))]
[_
(error 'ground-vm
"Outermost VM may not spawn new siblings or send or receive metamessages")]))))
;---------------------------------------------------------------------------
(define (yield k)
(kernel-mode-transition (subscription 'none (lambda (_) (k)) '() '())
'()
'()
'()))
(define (quit)
(kernel-mode-transition (subscription 'none #f '() '())
'()
'()
'()))
(define (print x k)
(kernel-mode-transition (subscription 'none (lambda (_) (k)) '() '())
'()
(list (lambda () (pretty-print x)))
'()))
(define (super-alarm msecs)
(wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds))))
(define (sleep n k)
(kernel-mode-transition (subscription 'none
#f
'()
(list (message-handler
(super-alarm (+ (current-inexact-milliseconds) n))
(lambda (_) (k)))))
'()
'()
'()))
(ground-vm #f ;; TODO - fix this - what's a better way of correlating
;; metamessages with their metamessagepatterns??
(lambda ()
(sleep 1000
(lambda ()
(yield
(lambda ()
(print "HELLO"
quit)))))))