Another step closer to a metacircular driver.
This commit is contained in:
parent
4ced01301e
commit
114595257c
168
os.rkt
168
os.rkt
|
@ -3,6 +3,7 @@
|
||||||
;; Virtualized operating system.
|
;; Virtualized operating system.
|
||||||
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
|
(require racket/list)
|
||||||
(require "functional-queue.rkt")
|
(require "functional-queue.rkt")
|
||||||
|
|
||||||
(provide ...)
|
(provide ...)
|
||||||
|
@ -48,53 +49,144 @@
|
||||||
;; - the type of messages to other VMs, MetaMessage
|
;; - the type of messages to other VMs, MetaMessage
|
||||||
;; - the type of patterns over MetaMessages, MetaMessageEvent
|
;; - the type of patterns over MetaMessages, MetaMessageEvent
|
||||||
|
|
||||||
;; A VM is a (vm Map<Pid,Process>
|
;; A VM is a (vm ListBagOf<Subscription>
|
||||||
;; QueueOf<Message>
|
;; QueueOf<Event>). ;; TODO: make unordered?
|
||||||
;; QueueOf<InterruptK>).
|
(struct vm (subscriptions pending-events) #:transparent)
|
||||||
(struct vm (process-table pending-messages runnable) #:transparent)
|
|
||||||
|
|
||||||
;; A Pid is some eq?-comparable object, guaranteed to be unique within
|
;; A UserEvent is one of
|
||||||
;; the scope of a single VM. It IDentifies a Process.
|
;; -- (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
|
;; A KernelEvent is one of
|
||||||
;; the scope of a single VM's process. It IDentifies a Subscription.
|
;; -- (meta-message MetaMessage), a message emitted onto the
|
||||||
|
;; containing bus
|
||||||
|
(struct meta-message (body) #:transparent)
|
||||||
|
|
||||||
;; A Subscription is a (subscription Sid (Message -> Boolean) TrapK).
|
;; An Event is a UserEvent or a KernelEvent.
|
||||||
(struct subscription (sid predicate handler) #:transparent)
|
|
||||||
|
|
||||||
;; An Action is one of
|
;; An EventHandler is an (event-handler Boolean (Event -> Boolean) TrapK<Event>)
|
||||||
;; -- (send-message Message), a message to emit onto the bus
|
(struct event-handler (meta? matcher k) #:transparent)
|
||||||
;; -- (spawn-process InterruptK), a new sibling process to start
|
|
||||||
;; -- (subscribe sid
|
|
||||||
|
|
||||||
;; A TrapK is a Message -> InterruptK, representing a suspended
|
;; A TrapK<X> is a X -> InterruptK, representing a suspended process
|
||||||
;; process waiting for some information from the VM before it can
|
;; waiting for some information from the VM before it can continue.
|
||||||
;; continue.
|
|
||||||
|
|
||||||
;; An InterruptK is a
|
;; An InterruptK is a
|
||||||
;; ProcessState SetOf<Subscription>
|
;; ProcessState -> KernelModeTransition
|
||||||
;; -> ListOf<Message> ProcessState SetOf<Subscription> ListOf<InterruptK>
|
|
||||||
;;
|
|
||||||
;; representing a suspended process that can run instantly without
|
;; representing a suspended process that can run instantly without
|
||||||
;; waiting for more information from the VM. The inputs are the state
|
;; waiting for more information from the VM. The input is the state of
|
||||||
;; of the process and its current set of subscriptions, and the
|
;; the process, and the output is the information passed back to the
|
||||||
;; outputs are a list of messages to emit into the VM's communication
|
;; VM when the process yields the CPU.
|
||||||
;; bus, as well as possibly-updated process state and subscription
|
|
||||||
;; list, and a list of new processes to spawn.
|
;; 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)
|
(define (make-vm boot)
|
||||||
(vm (hash)
|
(boot-process boot (vm (list) (make-queue) (make-queue))))
|
||||||
(make-queue)
|
|
||||||
(enqueue (make-queue) boot)))
|
|
||||||
|
|
||||||
;; 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)
|
;; (A kind of Meta-InterruptK)
|
||||||
(define (run-vm state meta-subscriptions)
|
(define (run-vm state)
|
||||||
(define state-after-dispatch
|
(define state-after-timeouts state) ;; TODO
|
||||||
(foldl dispatch-message
|
(define state-after-events
|
||||||
(struct-copy vm state [pending-messages (make-queue)])
|
(foldl dispatch-event
|
||||||
(vm-pending-messages state)))
|
(struct-copy vm state-after-timeouts [pending-events (make-queue)])
|
||||||
(define state-after-run
|
(vm-pending-events state)))
|
||||||
(foldl run-process
|
(trap-to-metalevel state-after-events))
|
||||||
(struct-copy vm state [runnable (make-queue)])
|
|
||||||
(vm-runnable state)))
|
(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)))
|
||||||
|
|
Loading…
Reference in New Issue