diff --git a/TODO b/TODO index 87ace0f..424271e 100644 --- a/TODO +++ b/TODO @@ -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 diff --git a/dump-bytes.rkt b/dump-bytes.rkt index 6b568ef..85b8398 100644 --- a/dump-bytes.rkt +++ b/dump-bytes.rkt @@ -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)) diff --git a/indenting.el b/indenting.el index 7ea17c2..e2d9098 100644 --- a/indenting.el +++ b/indenting.el @@ -1,3 +1,4 @@ +;; Emacs indent settings (mapcar #'(lambda (x) (put x 'scheme-indent-function 1)) '(transition extend-transition subscribe subscribe/fresh unsubscribe diff --git a/os-big-bang-example.rkt b/os-big-bang-example.rkt index f1745ca..d1088ec 100644 --- a/os-big-bang-example.rkt +++ b/os-big-bang-example.rkt @@ -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) diff --git a/os-big-bang-testing.rkt b/os-big-bang-testing.rkt index 091d447..bb7c034 100644 --- a/os-big-bang-testing.rkt +++ b/os-big-bang-testing.rkt @@ -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 -> 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") diff --git a/os-big-bang.rkt b/os-big-bang.rkt index 4ce1af2..e8603d4 100644 --- a/os-big-bang.rkt +++ b/os-big-bang.rkt @@ -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) diff --git a/os-example.rkt b/os-example.rkt index 579f373..4451e8c 100644 --- a/os-example.rkt +++ b/os-example.rkt @@ -1,4 +1,5 @@ #lang racket/base +;; Trivial demonstration of a raw os.rkt virtual machine. (require "os.rkt") (require racket/pretty) diff --git a/os-timer.rkt b/os-timer.rkt index c2df476..2542d60 100644 --- a/os-timer.rkt +++ b/os-timer.rkt @@ -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 diff --git a/os-udp-test-big-bang.rkt b/os-udp-test-big-bang.rkt index e13e0fc..ca1157d 100644 --- a/os-udp-test-big-bang.rkt +++ b/os-udp-test-big-bang.rkt @@ -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") diff --git a/os-udp-test-userland.rkt b/os-udp-test-userland.rkt index 02eb83a..450b7d3 100644 --- a/os-udp-test-userland.rkt +++ b/os-udp-test-userland.rkt @@ -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") diff --git a/os-udp.rkt b/os-udp.rkt index 10ba0cf..2049de2 100644 --- a/os-udp.rkt +++ b/os-udp.rkt @@ -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 () diff --git a/os-userland-example.rkt b/os-userland-example.rkt index af45920..2d16eb0 100644 --- a/os-userland-example.rkt +++ b/os-userland-example.rkt @@ -1,4 +1,5 @@ #lang racket/base +;; Trivial example of os-userland. (require "os-userland-stdlib.rkt") diff --git a/os.rkt b/os.rkt index 2fdb65b..e265757 100644 --- a/os.rkt +++ b/os.rkt @@ -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 -;; QueueOf ;; TODO: make unordered? -;; QueueOf ;; TODO: make unordered? -;; QueueOf). +;; ListOf ;; TODO: make unordered? +;; ListOf ;; TODO: make unordered? +;; ListOf +;; 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) +;; A MessageHandler is a (message-handler MessagePattern TrapK) (struct message-handler (pattern k) #:transparent) ;; A KernelModeTransition is a @@ -131,13 +128,11 @@ ;; A ListBagOf is a ListOf 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 +;; 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 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) +;; -> 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