Improve documentation and comments.

This commit is contained in:
Tony Garnock-Jones 2012-02-15 11:39:31 -05:00
parent c028d852d0
commit 49b6d0dfb7
13 changed files with 176 additions and 48 deletions

6
TODO
View File

@ -8,3 +8,9 @@ It feels like those lowest-level drivers are listening for *demand*
i.e. they're listening for presence and are then acting to supply such
demand. Think about the relationships between presence (both positive
and negative), and interfacing to ad-hoc sources and sinks.
### Old, possibly-still-relevant TODOs from os.rkt
- is timeout really primitive? If so, isn't presence primitive?
- what about metatimeout?
- enforce user-mode restrictions

View File

@ -1,7 +1,10 @@
#lang racket/base
;; Pretty hex dump output of a Bytes.
(provide dump-bytes!)
;; Exact Exact -> String
;; Returns the "0"-padded, width-digit hex representation of n
(define (hex width n)
(define s (number->string n 16))
(define slen (string-length s))
@ -10,6 +13,8 @@
((= slen width) s)
((> slen width) (substring s 0 width))))
;; Bytes Exact -> Void
;; Prints a pretty hex/ASCII dump of bs on (current-output-port).
(define (dump-bytes! bs requested-count)
(define count (min requested-count (bytes-length bs)))
(define clipped (subbytes bs 0 count))

View File

@ -1,3 +1,4 @@
;; Emacs indent settings
(mapcar #'(lambda (x) (put x 'scheme-indent-function 1))
'(transition extend-transition
subscribe subscribe/fresh unsubscribe

View File

@ -1,4 +1,6 @@
#lang racket/base
;; Trivial demonstration of an os-big-bang style virtual machine.
;; Engages in various I/O and timer operations.
(require racket/match)
(require racket/port)

View File

@ -1,4 +1,5 @@
#lang racket/base
;; Utilities for testing os-big-bang worlds.
(require racket/match)
(require rackunit)
@ -11,6 +12,10 @@
(transition (transition-state t) (transition-actions t)) ;; autoflattens
(transition t '()))) ;; wrap for convenient comparison
;; (on-message ...) World Any World ListOf<Action> -> Void
;; Passes the given message to the given message-handler, with the
;; given initial-w. Compares the resulting world and list of actions
;; to the expected world and list of actions using check-equal?.
(define (check-message-handler mh initial-w message final-w expected-actions)
(match-define (on-message pattern handler) mh)
(check-true (pattern message) "Message-handler pattern did not match message provided")

View File

@ -1,6 +1,5 @@
#lang racket/base
; Evented userland for os.rkt
; Evented userland for os.rkt. Maintains persistent subscriptions.
(require racket/set)
(require racket/match)

View File

@ -1,4 +1,5 @@
#lang racket/base
;; Trivial demonstration of a raw os.rkt virtual machine.
(require "os.rkt")
(require racket/pretty)

View File

@ -1,22 +1,42 @@
#lang racket/base
;; Timer drivers for os.rkt
(require racket/match)
(require "os-big-bang.rkt")
(require "os-udp.rkt")
(provide (struct-out set-timer)
(struct-out timer-expired)
timer-driver
timer-relay)
;; (set-timer Any Number Boolean)
;; The timer driver listens for messages of this type, and when it
;; hears one, sets an alarm that will later send a corresponding
;; timer-expired message.
(struct set-timer (label msecs relative?) #:prefab)
;; (timer-expired Any Number)
;; Message sent by the timer driver upon expiry of a timer. Contains
;; the label specified in the corresponding set-timer message, and
;; also the current absolute time from the outside world.
(struct timer-expired (label msecs) #:prefab)
;; Something like this should be part of racket
;; Note that (set-timer 'current-time 0 #f) causes an immediate reply
;; of (timer-expired 'current-time (current-inexact-milliseconds)),
;; which can be used for an event-oriented interface to reading the
;; system clock.
;; 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.
(define (timer-evt msecs relative?)
(wrap-evt (alarm-evt (if relative? (+ (current-inexact-milliseconds) msecs) msecs))
(lambda (_) (current-inexact-milliseconds))))
;; [Symbol] -> BootK
;; Process for mapping this-level timer requests to meta-level timer
;; events and back.
(define (timer-driver [self-id 'timer-driver])
(os-big-bang 'no-state
(subscribe 'timer-setter
@ -32,6 +52,10 @@
(unsubscribe label)
(send-message (timer-expired reply-label now)))])))]))))
;; [Symbol] -> BootK
;; Process for mapping this-level timer requests to meta-level timer
;; requests. Useful when running nested VMs: essentially extends timer
;; support up the branches of the VM tree toward the leaves.
(define (timer-relay [self-id 'timer-relay])
(os-big-bang 'no-state
(subscribe 'timer-relay

View File

@ -1,4 +1,5 @@
#lang racket/base
;; Trivial example program demonstrating os-udp.rkt working with os-big-bang.
(require racket/match)
(require "os-big-bang.rkt")

View File

@ -1,4 +1,5 @@
#lang racket/base
;; Trivial example program demonstrating os-udp.rkt working with os-userland.
(require racket/match)
(require "os-userland-stdlib.rkt")

View File

@ -1,5 +1,4 @@
#lang racket/base
;; UDP drivers for os.rkt
(require racket/match)
@ -25,6 +24,8 @@
;; TODO: BUG?: Routing packets between two local sockets won't work
;; because the patterns aren't set up to recognise that situation.
;; BootK
;; Process acting as a UDP socket factory.
(define udp-driver
(userland
(lambda ()
@ -41,6 +42,9 @@
(spawn (userland (udp-closer sname s)))
sname]))))
;; UdpAddress UdpSocket -> -> Void
;; Relays this-level UDP messages "originating" at the given sname
;; down to real Racket UDP send I/O actions on the given socket.
(define ((udp-sender sname s))
(let loop ()
(wait (message-handlers
@ -50,6 +54,10 @@
(meta-send (lambda () (udp-send-to s host port body)))
(loop)]))))
;; UdpAddress UdpSocket Exact -> -> Void
;; Relays meta-level UDP messages arriving at the given socket up to
;; this-level UdpPacket messages with sink equal to the given
;; sname. Received packets are limited to the given buffer-size.
(define ((udp-receiver sname s buffer-size))
(define buffer (make-bytes buffer-size))
(let loop ()
@ -64,11 +72,19 @@
(send (udp-packet (udp-address host port) sname packet))
(loop)]))))
;; UdpAddress UdpSocket -> -> Void
;; Waits for a (list 'close sname) message. When it gets one, closes
;; the socket. Note that the other socket-specific driver processes
;; are also listening for close messages of this form.
(define ((udp-closer sname s))
(wait (message-handlers
[`(close ,(== sname))
(udp-close s)])))
;; BootK
;; Debugging aide: produces pretty hex dumps of UDP packets sent on
;; this network. Also prints out other messages without special
;; formatting.
(define udp-spy
(userland
(lambda ()

View File

@ -1,4 +1,5 @@
#lang racket/base
;; Trivial example of os-userland.
(require "os-userland-stdlib.rkt")

152
os.rkt
View File

@ -1,5 +1,4 @@
#lang racket/base
;; Virtualized operating system.
(require racket/match)
@ -28,12 +27,15 @@
;; 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 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.
;; 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.
;; 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
@ -43,23 +45,17 @@
;; 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.
;; 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/. 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.
;; /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
@ -67,13 +63,20 @@
;; - 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.
;; to match a message against a pattern. A MetaPatternPredicate is
;; similar, but for metamessages.
;; A VM is a (vm ListBagOf<Suspension>
;; QueueOf<Message> ;; TODO: make unordered?
;; QueueOf<MetaMessage> ;; TODO: make unordered?
;; QueueOf<BootK>).
;; ListOf<Message> ;; TODO: make unordered?
;; ListOf<MetaMessage> ;; TODO: make unordered?
;; ListOf<BootK>
;; PatternPredicate
;; MetaPatternPredicate).
(struct vm (suspensions
pending-messages
pending-meta-messages
@ -106,13 +109,7 @@
message-handlers
meta-message-handlers) #:transparent)
;; A HID is a per-VM unique value, used to identify specific
;; MetaMessageHandlers. Here, we use gensyms, though an alternative
;; (and purer) approach would be to keep a counter in the VM and use
;; that to construct IDs.
;; A MessageHandler is one of
;; -- (message-handler MessagePattern TrapK<Message>)
;; A MessageHandler is a (message-handler MessagePattern TrapK<Message>)
(struct message-handler (pattern k) #:transparent)
;; A KernelModeTransition is a
@ -131,13 +128,11 @@
;; A ListBagOf<X> is a ListOf<X> with the additional constraint that
;; order isn't meaningful.
;; 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
;; BootK -> VM
;; 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])
@ -149,7 +144,10 @@
meta-pattern-predicate))
;; VM -> KernelModeTransition
;; (A kind of Meta-InterruptK)
;; (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))
@ -163,6 +161,9 @@
'()
'())))
;; 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)
@ -171,21 +172,39 @@
(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 mmh))))
(message-handler (message-handler-pattern mmh) dispatch-meta-message)))
(define (((dispatch-meta-message mmh) message) state)
;; 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)
@ -194,6 +213,8 @@
(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
@ -208,12 +229,23 @@
[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 '() '())
@ -222,9 +254,15 @@
[(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)
@ -232,6 +270,14 @@
(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
@ -246,6 +292,8 @@
[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)))
@ -257,6 +305,12 @@
(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])
@ -264,13 +318,18 @@
#: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)))
;;---------------------------------------------------------------------------
(define (nested-vm-inert? sub)
(match sub
;; 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.
@ -283,12 +342,19 @@
(define (match-ground-event p m)
(equal? (ground-event-pattern-tag p) (ground-event-value-tag m)))
;; PatternPredicate ( -> KernelModeTransition ) -> Void
;; 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 its argument VM until it becomes (provably) inert.
;;
;; 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