commit 1f1eb5f548628243f158b6703a37745084689e78 Author: Tony Garnock-Jones Date: Wed Feb 15 10:33:53 2012 -0500 Split from racket-dns at 0bd5bb093501261fcea90156b26fbe73867b5cbd diff --git a/TODO b/TODO new file mode 100644 index 0000000..87ace0f --- /dev/null +++ b/TODO @@ -0,0 +1,10 @@ +## os.rkt and friends + + - move from quasiquoted to prefab structs + - define a prefab struct for every evt? that we want to use + - define lowest-level drivers for each prefab struct + +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. diff --git a/dump-bytes.rkt b/dump-bytes.rkt new file mode 100644 index 0000000..6b568ef --- /dev/null +++ b/dump-bytes.rkt @@ -0,0 +1,45 @@ +#lang racket/base + +(provide dump-bytes!) + +(define (hex width n) + (define s (number->string n 16)) + (define slen (string-length s)) + (cond + ((< slen width) (string-append (make-string (- width slen) #\0) s)) + ((= slen width) s) + ((> slen width) (substring s 0 width)))) + +(define (dump-bytes! bs requested-count) + (define count (min requested-count (bytes-length bs))) + (define clipped (subbytes bs 0 count)) + (define (dump-hex i) + (if (< i count) + (display (hex 2 (bytes-ref clipped i))) + (display " ")) + (display #\space)) + (define (dump-char i) + (if (< i count) + (let ((ch (bytes-ref clipped i))) + (if (<= 32 ch 127) + (display (integer->char ch)) + (display #\.))) + (display #\space))) + (define (for-each-between f low high) + (do ((i low (+ i 1))) + ((= i high)) + (f i))) + (define (dump-line i) + (display (hex 8 i)) + (display #\space) + (for-each-between dump-hex i (+ i 8)) + (display ": ") + (for-each-between dump-hex (+ i 8) (+ i 16)) + (display #\space) + (for-each-between dump-char i (+ i 8)) + (display " : ") + (for-each-between dump-char (+ i 8) (+ i 16)) + (newline)) + (do ((i 0 (+ i 16))) + ((>= i count)) + (dump-line i))) diff --git a/indenting.el b/indenting.el new file mode 100644 index 0000000..7ea17c2 --- /dev/null +++ b/indenting.el @@ -0,0 +1,5 @@ +(mapcar #'(lambda (x) (put x 'scheme-indent-function 1)) + '(transition extend-transition + subscribe subscribe/fresh unsubscribe + os-big-bang + message-handlers meta-message-handlers ground-message-handler)) diff --git a/os-big-bang-example.rkt b/os-big-bang-example.rkt new file mode 100644 index 0000000..f1745ca --- /dev/null +++ b/os-big-bang-example.rkt @@ -0,0 +1,79 @@ +#lang racket/base + +(require racket/match) +(require racket/port) +(require "os-big-bang.rkt") + +(define display-driver-handler + (message-handlers w + [`(display ,message) + (transition w (send-meta-message (lambda () + (display message) + (flush-output))))])) + +(define read-line-driver-handler + (message-handlers w + [`(request ,reply-addr read-line) + (transition w + (subscribe/fresh sid + (ground-message-handler w + [((list 'read-line reply-addr) + (read-line-evt (current-input-port) 'any) + => l) + (transition w + (unsubscribe sid) + (send-message `(reply ,reply-addr ,l)))])))])) + +;; This should be part of racket +(define (time-evt msecs) + (wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds)))) + +(define (tick-driver self-sid interval) + (let loop ((last-tick-time 0) (counter 0)) + (define next-time (+ last-tick-time interval)) + (subscribe self-sid + (ground-message-handler w + [((list 'timer-alarm next-time) + (time-evt next-time) + => now) + (transition w + (unsubscribe self-sid) + (send-message `(tick ,counter ,now)) + (loop now (+ counter 1)))])))) + +(define main + (os-big-bang 'none + (subscribe 'display-driver display-driver-handler) + (subscribe 'read-line-driver read-line-driver-handler) + (tick-driver 'ticker 1000) + (send-message `(display "Hello! ")) + (send-message 'greet-loop) + (subscribe 'greet-loop-handler + (message-handlers w + ['greet-loop + (transition w + (send-message `(display "Enter your name:\n")) + (send-message `(request read-name read-line)))])) + (subscribe 'ticker-handler + (message-handlers w + [`(tick ,counter ,_) + (transition w + (send-message + `(display ,(string-append "TICK " + (number->string counter) + "\n"))))])) + (subscribe 'read-line-result-handler + (message-handlers w + [`(reply read-name ,(== eof)) + (transition w + (send-message `(display "Goodbye!\n")))] + [`(reply read-name ,name) + (transition w + (send-message `(display "Hello, ")) + (send-message `(display ,name)) + (send-message `(display "!\n")) + (unsubscribe 'ticker) + (send-message 'greet-loop) + )])))) + +(ground-vm main) diff --git a/os-big-bang-testing.rkt b/os-big-bang-testing.rkt new file mode 100644 index 0000000..091d447 --- /dev/null +++ b/os-big-bang-testing.rkt @@ -0,0 +1,21 @@ +#lang racket/base + +(require racket/match) +(require rackunit) +(require "os-big-bang.rkt") + +(provide check-message-handler) + +(define (flatten-transition t) + (if (transition? t) + (transition (transition-state t) (transition-actions t)) ;; autoflattens + (transition t '()))) ;; wrap for convenient comparison + +(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") + (define v (match (handler message initial-w) + [(? transition? t) t] + [new-w (transition new-w '())])) + (check-equal? (flatten-transition v) (transition final-w expected-actions) + "Produced world-and-actions did not match expected world-and-actions")) diff --git a/os-big-bang.rkt b/os-big-bang.rkt new file mode 100644 index 0000000..4ce1af2 --- /dev/null +++ b/os-big-bang.rkt @@ -0,0 +1,158 @@ +#lang racket/base + +; Evented userland for os.rkt + +(require racket/set) +(require racket/match) +(require racket/list) +(require "os.rkt") + +(provide (struct-out subscribe) + subscribe/fresh + + (struct-out unsubscribe) + (struct-out send-message) + (struct-out send-meta-message) + (struct-out spawn) + + (struct-out on-message) + (struct-out on-meta-message) + message-handlers + meta-message-handlers + ground-message-handler + + (except-out (struct-out transition) transition) + (rename-out [make-transition transition]) + extend-transition + + ground-vm ;; reprovided from os.rkt for convenience + os-big-bang + os-big-bang/transition) + +;; A SID is an Any, a world-specific identifier for subscriptions. + +;; An Action is one of +;; -- (subscribe SID EventDescription), to add a subscription +;; -- (unsubscribe SID), to remove ALL previously-added subscriptions with this SID +;; -- (send-message Message), to emit a message into the local medium +;; -- (send-meta-message MetaMessage), to emit a message into the containing medium +;; -- (spawn BootK), to start a new sibling in the raw os.rkt eventing model +(struct subscribe (sid event-description) #:transparent) +(struct unsubscribe (sid) #:transparent) +(struct send-message (body) #:transparent) +(struct send-meta-message (body) #:transparent) +(struct spawn (thunk) #:transparent) + +;; An EventDescription is one of +;; -- (on-message MessagePattern (Message WorldState -> Transition)), conditionally +;; invoked when a message arrives +;; -- (on-meta-message MetaPattern (MetaMessage WorldState -> Transition)), conditionally +;; invoked when a metamessage arrives +;; If multiple EventDescriptions match a given event, one is +;; nondeterministically selected. +(struct on-message (pattern handler) #:transparent) +(struct on-meta-message (pattern handler) #:transparent) + +;; A Transition is either +;; -- a (transition WorldState ListOf) or +;; -- a WorldState +(struct transition (state actions) #:transparent) +(define (make-transition state . actions) (transition state actions)) + +;; Transition [Action ...] -> Transition +;; Append the given actions to the transition given as the first argument. +(define (extend-transition t . more-actions) + (match t + [(transition state actions) (transition state (list actions more-actions))] + [state (transition state more-actions)])) + +;; A World is a (world WorldState Map>), a +;; representation of a suspended world and its active subscriptions. +(struct world (state subscriptions) #:transparent) + +(define-syntax subscribe/fresh + (syntax-rules () + ((_ id-binder event-description) + (let ((id-binder (gensym 'id-binder))) + (subscribe id-binder event-description))))) + +(define-syntax message-handlers* + (syntax-rules () + ((_ action-constructor old-state-pattern [pattern body ...] ...) + (action-constructor (match-lambda [pattern #t] ... [_ #f]) + (lambda (message old-state) + (match-define old-state-pattern old-state) + (match message + [pattern body ...] ...)))))) + +(define-syntax message-handlers + (syntax-rules () + ((_ old-state-pattern [pattern body ...] ...) + (message-handlers* on-message old-state-pattern [pattern body ...] ...)))) + +(define-syntax meta-message-handlers + (syntax-rules () + ((_ old-state-pattern [pattern body ...] ...) + (message-handlers* on-meta-message old-state-pattern [pattern body ...] ...)))) + +(define-syntax ground-message-handler + (syntax-rules (=>) + ((_ old-state-pattern [(tag-expr evt-expr => pattern) body ...]) + (on-meta-message (ground-event-pattern tag-expr evt-expr) + (lambda (meta-message old-state) + (match-define old-state-pattern old-state) + (match meta-message + [(ground-event-value _ pattern) body ...])))))) + +(define (world->os-suspension w) + (suspension w + #f + (for*/list ([(sid vs) (world-subscriptions w)] + [v vs] + #:when (on-message? v)) + (match-define (on-message pattern handler) v) + (message-handler pattern (wrap-handler handler))) + (for*/list ([(sid vs) (world-subscriptions w)] + [v vs] + #:when (on-meta-message? v)) + (match-define (on-meta-message pattern handler) v) + (message-handler pattern (wrap-handler handler))))) + +(define (((wrap-handler handler) message) w) + (maybe-transition->os-transition w (handler message (world-state w)))) + +(define (maybe-transition->os-transition w t) + (if (transition? t) + (transition->os-transition w t) + (transition->os-transition w (transition t '())))) + +(define (transition->os-transition w t) + (match-define (transition state unflattened-actions) t) + (define actions (flatten unflattened-actions)) + (kernel-mode-transition (world->os-suspension (update-world w state actions)) + (for/list [(a actions) #:when (send-message? a)] + (send-message-body a)) + (for/list [(a actions) #:when (send-meta-message? a)] + (send-meta-message-body a)) + (for/list [(a actions) #:when (spawn? a)] + (spawn-thunk a)))) + +(define (update-world w new-state actions) + (world new-state + (foldl (lambda (action old-map) + (match action + [(subscribe sid desc) + (hash-update old-map sid + (lambda (s) (set-add s desc)) + (lambda () (set desc)))] + [(unsubscribe sid) + (hash-remove old-map sid)] + [_ old-map])) + (world-subscriptions w) + actions))) + +(define (os-big-bang initial-state . initial-actions) + (os-big-bang/transition (transition initial-state initial-actions))) + +(define (os-big-bang/transition t) + (lambda () (transition->os-transition (world (void) (hash)) t))) diff --git a/os-example.rkt b/os-example.rkt new file mode 100644 index 0000000..579f373 --- /dev/null +++ b/os-example.rkt @@ -0,0 +1,64 @@ +#lang racket/base + +(require "os.rkt") +(require racket/pretty) + +(define (yield k) + (kernel-mode-transition (suspension 'none (lambda (_) (k)) '() '()) + '() + '() + '())) + +(define (quit) + (kernel-mode-transition (suspension 'none #f '() '()) + '() + '() + '())) + +(define (print x k) + (kernel-mode-transition (suspension '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 (suspension 'none + #f + '() + (list (message-handler + (let ((wakeup-time + (+ (current-inexact-milliseconds) n))) + (ground-event-pattern + (list 'alarm wakeup-time) + (super-alarm wakeup-time))) + (lambda (_message) + (lambda (_state) + (k)))))) + '() + '() + '())) + +(define (spawn thunk k) + (kernel-mode-transition (suspension 'none (lambda (_) (k)) '() '()) + '() + '() + (list thunk))) + +(define (example-process delay) + (print "SLEEPING" + (lambda () + (sleep delay + (lambda () + (yield + (lambda () + (print "HELLO" + quit)))))))) + +(ground-vm (lambda () + (spawn (lambda () + (example-process 1000)) + (lambda () + (example-process 2000))))) diff --git a/os-timer.rkt b/os-timer.rkt new file mode 100644 index 0000000..3cbd1a1 --- /dev/null +++ b/os-timer.rkt @@ -0,0 +1,49 @@ +#lang racket/base + +(require racket/match) +(require "codec.rkt") +(require "os-big-bang.rkt") +(require "os-udp.rkt") + +(provide (struct-out set-timer) + (struct-out timer-expired) + timer-driver + timer-relay) + +(struct set-timer (label msecs relative?) #:prefab) +(struct timer-expired (label msecs) #:prefab) + +;; Something like this should be part of racket +(define (timer-evt msecs relative?) + (wrap-evt (alarm-evt (if relative? (+ (current-inexact-milliseconds) msecs) msecs)) + (lambda (_) (current-inexact-milliseconds)))) + +(define (timer-driver [self-id 'timer-driver]) + (os-big-bang 'no-state + (subscribe 'timer-setter + (message-handlers w + [(set-timer reply-label msecs relative?) + (transition w + (subscribe/fresh label + (ground-message-handler w + [((list self-id label) + (timer-evt msecs relative?) + => now) + (transition w + (unsubscribe label) + (send-message (timer-expired reply-label now)))])))])))) + +(define (timer-relay [self-id 'timer-relay]) + (os-big-bang 'no-state + (subscribe 'timer-relay + (message-handlers w + [(set-timer reply-label msecs relative?) + (define timer-id (list self-id reply-label)) + (transition w + (send-meta-message (set-timer timer-id msecs relative?)) + (subscribe/fresh label + (meta-message-handlers w + [(timer-expired (== timer-id) now) + (transition w + (unsubscribe label) + (send-message (timer-expired reply-label now)))])))])))) diff --git a/os-udp-test-big-bang.rkt b/os-udp-test-big-bang.rkt new file mode 100644 index 0000000..e13e0fc --- /dev/null +++ b/os-udp-test-big-bang.rkt @@ -0,0 +1,45 @@ +#lang racket/base + +(require racket/match) +(require "os-big-bang.rkt") +(require (only-in "os-userland.rkt" userland)) +(require "os-udp.rkt") +(require "os-big-bang-testing.rkt") + +(define (packet-handler sname) + (message-handlers w + [(udp-packet source (== sname) body) + (transition w + (send-message (udp-packet sname source body)))])) + +(check-message-handler (packet-handler (udp-address #f 5555)) + 'none + (udp-packet (udp-address "127.0.0.1" 12345) (udp-address #f 5555) #"abcd") + 'none + (list (send-message (udp-packet (udp-address #f 5555) + (udp-address "127.0.0.1" 12345) + #"abcd")))) + +(define echoer + (os-big-bang 'none + (send-message `(request create-echo-socket (udp new 5555 65536))) + (subscribe/fresh sub + (message-handlers w + [`(reply create-echo-socket ,sname) + (transition w + (unsubscribe sub) + (subscribe 'packet-handler (packet-handler sname)))])))) + +(define spy + (os-big-bang 'none + (subscribe 'spy (message-handlers w [x (write `(MESSAGE ,x)) (newline)])))) + +(define (main) + (ground-vm + (os-big-bang 'none + (spawn spy) + (spawn udp-driver) + (spawn echoer)))) + +(main) +;;(provide main) diff --git a/os-udp-test-userland.rkt b/os-udp-test-userland.rkt new file mode 100644 index 0000000..02eb83a --- /dev/null +++ b/os-udp-test-userland.rkt @@ -0,0 +1,20 @@ +#lang racket/base + +(require racket/match) +(require "os-userland-stdlib.rkt") +(require "os-udp.rkt") + +(ground-vm/stdlib + (userland + (lambda () + (spawn display-driver) + (spawn read-line-driver) + (spawn udp-driver) + (poll) + (define s (rpc `(udp new 5555 65536))) + (let loop () + (wait (message-handlers + [(udp-packet source (and sink (== s)) body) + (write `(udp (source ,source) (sink ,sink))) (newline) + (send (udp-packet sink source body)) + (loop)])))))) \ No newline at end of file diff --git a/os-udp.rkt b/os-udp.rkt new file mode 100644 index 0000000..10ba0cf --- /dev/null +++ b/os-udp.rkt @@ -0,0 +1,82 @@ +#lang racket/base + +;; UDP drivers for os.rkt + +(require racket/match) +(require racket/udp) +(require "dump-bytes.rkt") +(require "os-userland-stdlib.rkt") + +(provide (struct-out udp-address) + (struct-out udp-packet) + udp-driver + udp-spy) + +;; A UdpAddress is one of +;; -- a (udp-address String Uint16), representing a remote socket +;; -- a (udp-address #f Uint16), representing a local socket +(struct udp-address (host port) #:prefab) + +;; A UdpPacket is a (udp-packet UdpAddress UdpAddress Bytes), and +;; represents a packet appearing on our local "subnet" of the full UDP +;; network, complete with source, destination and contents. +(struct udp-packet (source destination body) #:prefab) + +;; TODO: BUG?: Routing packets between two local sockets won't work +;; because the patterns aren't set up to recognise that situation. + +(define udp-driver + (userland + (lambda () + (rpc-service + [`(udp new ,port-number ,buffer-size) + (define s (udp-open-socket #f #f)) + (when port-number + (udp-bind! s #f port-number)) + (define-values (_local-address local-port _remote-address _remote-port) + (udp-addresses s #t)) + (define sname (udp-address #f local-port)) + (spawn (userland (udp-sender sname s))) + (spawn (userland (udp-receiver sname s buffer-size))) + (spawn (userland (udp-closer sname s))) + sname])))) + +(define ((udp-sender sname s)) + (let loop () + (wait (message-handlers + [`(close ,(== sname)) + (void)] + [(udp-packet (== sname) (udp-address host port) body) + (meta-send (lambda () (udp-send-to s host port body))) + (loop)])))) + +(define ((udp-receiver sname s buffer-size)) + (define buffer (make-bytes buffer-size)) + (let loop () + (wait (message-handlers + [`(close ,(== sname)) + (void)]) + (meta-message-handlers + [((list 'udp-receive sname) + (udp-receive!-evt s buffer) + => (list packet-length host port)) + (define packet (subbytes buffer 0 packet-length)) + (send (udp-packet (udp-address host port) sname packet)) + (loop)])))) + +(define ((udp-closer sname s)) + (wait (message-handlers + [`(close ,(== sname)) + (udp-close s)]))) + +(define udp-spy + (userland + (lambda () + (let loop () + (wait (message-handlers + [(udp-packet source dest body) + (write `(UDP ,source --> ,dest)) (newline) + (dump-bytes! body (bytes-length body))] + [x + (write `(UDP ,x)) (newline)])) + (loop))))) diff --git a/os-userland-example.rkt b/os-userland-example.rkt new file mode 100644 index 0000000..af45920 --- /dev/null +++ b/os-userland-example.rkt @@ -0,0 +1,23 @@ +#lang racket/base + +(require "os-userland-stdlib.rkt") + +(define (main) + (spawn display-driver) + (spawn read-line-driver) + (spawn sleep-driver) + (spawn (userland (lambda () + (display "HI\n") + (sleep 1000) + (display "THERE\n")))) + (poll) ;; Wait for drivers to become ready (!) + ;; The Right Way to do this is to have presence integrated with subscription + (display "Hello! Enter your name:\n") + (define name (rpc 'read-line)) + (display "Hello, ") + (display name) + (display "!\n") + (sleep 1000) + (display "Goodbye\n")) + +(ground-vm/stdlib (userland main)) diff --git a/os-userland-stdlib.rkt b/os-userland-stdlib.rkt new file mode 100644 index 0000000..e815424 --- /dev/null +++ b/os-userland-stdlib.rkt @@ -0,0 +1,134 @@ +#lang racket/base + +(require racket/match) +(require racket/port) +(require "os-userland.rkt") + +(require (prefix-in base: racket/base)) + +(provide (all-from-out "os-userland.rkt") + + ground-vm/stdlib + + message-handlers + meta-message-handlers + + rpc + rpc-service + + display-driver + display + + read-line-driver + read-line + + current-time + sleep-driver + sleep + + receive + receive/timeout) + +(define (ground-vm/stdlib boot) + (ground-vm boot #:pattern-predicate (lambda (p m) (p m)))) + +(define-syntax message-handlers + (syntax-rules () + ((_ (pattern body ...) ...) + (list (wait-clause (match-lambda (pattern #t) (_ #f)) + (match-lambda (pattern body ...))) + ...)))) + +(define-syntax meta-message-handlers + (syntax-rules (=>) + ((_ [(tag-expr evt-expr => pattern) body ...] ...) + (list (wait-clause (ground-event-pattern tag-expr evt-expr) + (match-lambda ((ground-event-value _ pattern) body ...))) + ...)))) + +(define (rpc req) + (define reply-addr (gensym 'reply-addr)) ;;; !!! TODO: remove side-effect? + (send `(request ,reply-addr ,req)) + (wait (message-handlers + [`(reply ,(== reply-addr) ,v) + v]))) + +(define-syntax rpc-service + (syntax-rules () + [(_ [pattern body ...] ...) + (let loop () + (wait (message-handlers + [`(request ,reply-addr ,pattern) + (spawn (userland (lambda () + (define answer (let () body ...)) + (send `(reply ,reply-addr ,answer)))))] + ...)) + (loop))])) + +(define display-driver + (userland + (lambda () + (let loop () + (define message (wait (message-handlers [`(display ,message) message]))) + (meta-send (lambda () + (base:display message) + (flush-output))) + (loop))))) + +(define (display x) + (send `(display ,x))) + +(define read-line-driver + (userland + (lambda () + (rpc-service + [`read-line (wait (message-handlers) + (meta-message-handlers + [('read-line + (read-line-evt (current-input-port) 'any) + => line) + line]))])))) + +(define (read-line) + (rpc 'read-line)) + +(define (time-evt msecs) + (wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds)))) + +(define (wait-mmh msecs) + (meta-message-handlers + [((list 'time-evt msecs) + (time-evt msecs) + => current-time) + current-time])) + +(define (wait-until-time msecs) + (wait (message-handlers) + (wait-mmh msecs))) + +(define (current-time) + (wait-until-time 0)) + +(define sleep-driver + (userland + (lambda () + (rpc-service + [`(sleep ,msecs) + (send `(display (Sleeping ,msecs))) + (define now (wait-until-time (+ (current-time) msecs))) + (send `(display "\n")) + now])))) + +(define (sleep msecs) + (rpc `(sleep ,msecs))) + +(define-syntax receive + (syntax-rules () + ((_ mh-clause ...) + (wait (message-handlers mh-clause ...))))) + +(define-syntax receive/timeout + (syntax-rules () + ((_ timeout-msecs mh-clause ...) + (wait (message-handlers mh-clause ...) + (wait-mmh timeout-msecs))))) diff --git a/os-userland.rkt b/os-userland.rkt new file mode 100644 index 0000000..2a292ef --- /dev/null +++ b/os-userland.rkt @@ -0,0 +1,100 @@ +#lang racket/base + +; Userland for os.rkt: use of delimited continuations to invoke kernel services + +(require racket/match) +(require racket/list) +(require "os.rkt") + +(provide (struct-out wait-clause) + + ground-vm ;; convenience re-export + (struct-out ground-event-pattern) ;; convenience re-export + (struct-out ground-event-value) ;; convenience re-export + + userland + + send + meta-send + send* + + wait + poll + + spawn) + +(struct wait-clause (pattern handler-proc) #:transparent) + +(define prompt (make-continuation-prompt-tag 'os-userland)) + +;; ( -> Void) -> BootK +;; Wraps a thunk that uses the userland continuation-based approach to +;; simulating side effects so that it can be used as a BootK with a +;; KernelModeTransition. +(define (userland main) + (lambda () + (start-transaction ((reply-to (lambda (_) + (main) + 'finish)) + void)))) + +(define ((reply-to k) v) + (call-with-continuation-prompt (lambda () (k (v))) prompt)) + +(define (start-transaction first-action) + (accumulate-transaction '() '() '() first-action)) + +(define (accumulate-transaction messages meta-messages new-threads action) + (define (syscall sub) + (kernel-mode-transition sub + (reverse messages) + (reverse meta-messages) + (reverse new-threads))) + (match action + [`(actions ,ms ,mms ,thrs ,k) + (accumulate-transaction (append (reverse ms) messages) + (append (reverse mms) meta-messages) + (append (reverse thrs) new-threads) + (k void))] + [`(wait ,polling? ,mhs ,mmhs ,k) + (syscall (suspension k + (and polling? (lambda (k) (start-transaction (k void)))) + (wrap-handlers mhs) + (wrap-handlers mmhs)))] + [`finish + (syscall (suspension 'finished #f '() '()))])) + +(define (((invoke-handler proc) v) k) + (start-transaction (k (lambda () (proc v))))) + +(define (wrap-handlers hs) + (map (lambda (h) (message-handler (wait-clause-pattern h) + (invoke-handler (wait-clause-handler-proc h)))) + (flatten hs))) + +(define (call-in-kernel-context proc) + (call-with-composable-continuation + (lambda (k) (abort-current-continuation prompt + (lambda () (proc (reply-to k))))) + prompt)) + +(define (actions ms mms thrs) + (call-in-kernel-context (lambda (k) `(actions ,ms ,mms ,thrs ,k)))) + +(define (send message) + (actions (list message) '() '())) + +(define (meta-send meta-message) + (actions '() (list meta-message) '())) + +(define (send* messages [meta-messages '()]) + (actions messages meta-messages '())) + +(define (wait mhs [mmhs '()]) + (call-in-kernel-context (lambda (k) `(wait #f ,mhs ,mmhs ,k)))) + +(define (poll [mhs '()] [mmhs '()]) + (call-in-kernel-context (lambda (k) `(wait #t ,mhs ,mmhs ,k)))) + +(define (spawn thunk) + (actions '() '() (list thunk))) diff --git a/os.hs b/os.hs new file mode 100644 index 0000000..36def6a --- /dev/null +++ b/os.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE ExistentialQuantification #-} +-- MultiParamTypeClasses FunctionalDependencies +module OS where + +-- TODO try avoiding double-matching for metamessages and the need for +-- broadcast by introducing a facility for supporting event-pattern +-- subtyping + +import Control.Arrow ((>>>)) +import Data.Maybe +import Data.List +import Control.Concurrent.Chan + +data VM m mm = VM { suspensions :: [Suspension m mm], + messages :: [m], + metaMessages :: [mm], + runnables :: [Callback m mm ()] } +type Callback m mm state = (state -> KernelModeTransition m mm) +data Suspension m mm = forall state. Suspension + state + (Maybe (Callback m mm state)) + [Handler m mm state] + [MetaHandler m mm state] +data KernelModeTransition m mm = KernelModeTransition (Suspension m mm) + [m] + [mm] + [Callback m mm ()] +type Handler m mm state = (m -> Maybe (Callback m mm state)) +type MetaHandler m mm state = (mm -> Maybe (Callback m mm state)) + +newVM boot = VM { suspensions = [], + messages = [], + metaMessages = [], + runnables = [boot] } + +runVM :: VM m mm -> KernelModeTransition mm mm1 +runVM = rebuildSuspensions enqueuePoller >>> runRunnables >>> dispatchMessages >>> \ vm -> + let mms = reverse $ metaMessages vm + mmhs = concatMap extractDown $ suspensions vm + pollerK = if shouldPoll vm then Just runVM else Nothing + in + KernelModeTransition (Suspension (vm { metaMessages = [] }) pollerK mmhs []) mms [] [] + +rebuildSuspensions :: (VM m mm -> Suspension m mm -> VM m mm) -> (VM m mm) -> (VM m mm) +rebuildSuspensions f vm = foldl f (vm { suspensions = [] }) (suspensions vm) + +enqueuePoller :: VM m mm -> Suspension m mm -> VM m mm +enqueuePoller vm susp@(Suspension state k _ _) = + if isPolling susp + then vm { runnables = (\ () -> (fromJust k) state) : runnables vm } + else vm { suspensions = susp : suspensions vm } + +runRunnables :: VM m mm -> VM m mm +runRunnables vm = foldl runRunnable (vm { runnables = [] }) (reverse (runnables vm)) +runRunnable vm r = performTransition (r ()) vm + +dispatchMessages :: VM m mm -> VM m mm +dispatchMessages vm = foldr dispatchMessage (vm { messages = [] }) (messages vm) + +dispatchMessage m = rebuildSuspensions matchSuspension + where matchSuspension vm susp@(Suspension state _ mhs _) = + searchHandlers vm susp state m mhs + +searchHandlers vm susp state m [] = vm { suspensions = susp : suspensions vm } +searchHandlers vm susp state m (mh:mhs) = + case mh m of + Just h -> performTransition (h state) vm + Nothing -> searchHandlers vm susp state m mhs + +extractDown (Suspension _ _ _ mmhs) = map matchMetaMessage mmhs + where matchMetaMessage mmh mm = + case mmh mm of + Nothing -> Nothing + Just _ -> Just (runMetaHandler mm) + +isPolling (Suspension _ pollerK _ _) = isNothing pollerK +isBlocked = not . isPolling + +shouldPoll vm@(VM { messages = [], runnables = []}) = not $ all isBlocked (suspensions vm) +shouldPoll _ = True + +runMetaHandler :: mm -> (VM m mm) -> (KernelModeTransition mm mm1) +runMetaHandler mm = runVM . rebuildSuspensions dispatchMetaMessage + where dispatchMetaMessage vm susp@(Suspension state _ _ mmhs) = + searchHandlers vm susp state mm mmhs + +performTransition :: KernelModeTransition m mm -> VM m mm -> VM m mm +performTransition (KernelModeTransition susp ms mms cbs) vm = + vm { suspensions = susp : suspensions vm, + messages = reverse ms ++ (messages vm), + metaMessages = reverse mms ++ (metaMessages vm), + runnables = reverse cbs ++ (runnables vm) } + +--------------------------------------------------------------------------- +{- +type LabelledMessage a b = (a, b) + +groundVM :: Callback m (IO ()) () -> IO () +groundVM boot = do inboundChannel <- newChan + mainloop inboundChannel (runVM (makeVM boot)) + where mainloop ch (KernelModeTransition (Subscription newState pollingK mhs []) ms [] []) = do + runActions ch ms + case (newState, pollingK, mhs) of + (VM { messages = [], metaMessages = [], runnables = [] }, Nothing, []) -> + -- inert. + return () + _ -> + + + (when (not (nested-vm-inert? (kernel-mode-transition-subscription transition))) + (match transition + [(kernel-mode-transition (subscription new-state + polling-k + message-handlers + '()) + _ + '() + '()) + (define inbound-messages + (map (match-lambda [(message-handler e k) (wrap-evt e (lambda (v) (cons 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 (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")])))) +-} + +-- -- Values of type v are matchable by values of type p, yielding +-- -- residuals of type a. +-- class Matchable v p a | v -> p where +-- match :: p -> v -> Maybe a diff --git a/os.rkt b/os.rkt new file mode 100644 index 0000000..2fdb65b --- /dev/null +++ b/os.rkt @@ -0,0 +1,320 @@ +#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 + ) + +;; 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. +;; +;; Each VM provides a *communication bus* for its processes to +;; use. The communication bus is the only form of IPC the VM provides. +;; +;; 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 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. + +;; 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 + +;; A PatternPredicate is a (MessagePattern Message -> Boolean), used +;; to match a message against a pattern. + +;; A VM is a (vm ListBagOf +;; QueueOf ;; TODO: make unordered? +;; QueueOf ;; TODO: make unordered? +;; QueueOf). +(struct vm (suspensions + pending-messages + pending-meta-messages + pending-processes + pattern-predicate + meta-pattern-predicate) #:transparent) + +;; A TrapK 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 +;; ListBagOf +;; ListBagOf). +;; To poll the kernel, include a non-#f InterruptK. +(struct suspension (state + k + 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) +(struct message-handler (pattern k) #:transparent) + +;; A KernelModeTransition is a +;; (kernel-mode-transition Suspension +;; ListBagOf +;; ListBagOf +;; ListBagOf) +;; 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 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 +(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) +(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 + '() + '()))) + +(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))) + +(define (run-runnables state) + (foldl (lambda (r state) (perform-transition (r) state)) + (struct-copy vm state [pending-processes (list)]) + (reverse (vm-pending-processes state)))) + +(define (dispatch-messages state) + (foldl dispatch-message + (struct-copy vm state [pending-messages (list)]) + (reverse (vm-pending-messages state)))) + +(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)))) + +(define (((dispatch-meta-message mmh) 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 +(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)])) + +(define (enqueue-message message state) + (struct-copy vm state [pending-messages (cons message (vm-pending-messages state))])) + +(define (enqueue-runnable r state) + (struct-copy vm state [pending-processes (cons r (vm-pending-processes state))])) + +(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))])])) + +(define (enqueue-meta-message message state) + (struct-copy vm state [pending-meta-messages (cons message (vm-pending-meta-messages state))])) + +(define (dispatch-message message state) + (foldl (match-suspension message + (vm-pattern-predicate state) + suspension-message-handlers) + (struct-copy vm state [suspensions '()]) + (vm-suspensions 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))]))) + +(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)))) + +(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)))) + +(define default-pattern-predicate + (lambda (p m) (p m))) + +;;--------------------------------------------------------------------------- + +(define (nested-vm-inert? sub) + (match sub + [(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))) + +;; PatternPredicate ( -> 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 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)))) + (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")])))) diff --git a/universe.rkt b/universe.rkt new file mode 100644 index 0000000..b44d3cf --- /dev/null +++ b/universe.rkt @@ -0,0 +1,208 @@ +#lang racket/base + +;; Compatibility: 2htdp/universe's big-bang expressed in terms of ground-vm and os-big-bang. + +(require racket/match) +(require racket/class) +(require racket/async-channel) +(require racket/gui/base) +(require 2htdp/image) +(require "os-big-bang.rkt") + +(provide (struct-out stop-with) + on-tick + on-key + on-release + on-mouse + stop-when + to-draw + on-draw + big-bang) + +(struct stop-with (w) #:transparent) + +;; This should be part of racket +(define (time-evt msecs) + (wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds)))) + +(define (replace-world w1 w2) + (cond + [(stop-with? w2) (transition (stop-with-w w2) + (send-message `(new-state ,(stop-with-w w2))) + (send-message 'stop))] + [else (transition w2 (send-message `(new-state ,w2)))])) + +(define (stop w n) + (transition w (unsubscribe n))) + +(struct ticker-state (counter interval limit) #:transparent) + +(define-syntax on-tick + (syntax-rules () + ((_ tick-expr) + (on-tick tick-expr 1/28)) + ((_ tick-expr rate-expr) + (on-tick tick-expr rate-expr 0)) + ((_ tick-expr rate-expr limit-expr) + (list + (subscribe 'ticker-handler + (message-handlers w + ['tick (replace-world w (tick-expr w))] + ['stop (stop w 'ticker-handler)])) + (spawn (os-big-bang (ticker-state 0 rate-expr limit-expr) + (subscribe 'stop-listener + (message-handlers ts + ['stop (transition ts + (unsubscribe 'stop-listener) + (unsubscribe 'ticker))])) + (let loop ((next-alarm-time 0)) + (subscribe 'ticker + (ground-message-handler + (and w (ticker-state counter interval limit)) + [((list 'timer-alarm next-alarm-time) + (time-evt next-alarm-time) + => now) + (if (and (positive? limit) (>= counter limit)) + (transition w (unsubscribe 'ticker)) + (transition (ticker-state (+ counter 1) interval limit) + (unsubscribe 'ticker) + (loop (+ now (* 1000 interval))) + (send-message 'tick)))]))))))))) + +(define-syntax-rule (on-key key-expr) + (subscribe 'key-handler + (message-handlers w + [`(key-down ,kev) (replace-world w (key-expr w kev))] + ['stop (stop w 'key-handler)]))) + +(define-syntax-rule (on-release release-expr) + (subscribe 'release-handler + (message-handlers w + [`(key-up ,kev) (replace-world w (release-expr w kev))] + ['stop (stop w 'release-handler)]))) + +(define-syntax-rule (on-mouse mouse-expr) + (subscribe 'mouse-handler + (message-handlers w + [`(mouse ,x ,y ,mev) (replace-world w (mouse-expr w x y mev))] + ['stop (stop w 'mouse-handler)]))) + +(define-syntax-rule (stop-when last-world?) + (subscribe 'stop-when-handler + (message-handlers w + [`(new-state ,_) (if (last-world? w) + (replace-world w (stop-with w)) + w)] + ['stop (stop w 'stop-when-handler)]))) + +(define-syntax-rule (on-draw render-expr) (to-draw render-expr)) + +(define-syntax-rule (to-draw render-expr) + (subscribe 'draw-handler + (message-handlers w + [`(new-state ,_) (transition w (send-message `(render ,(render-expr w))))] + ['stop (stop w 'draw-handler)]))) + +(define (ui-actions c:ui->world c:world->ui) + (list + (spawn (os-big-bang 'none + (subscribe 'inbound-relay + (ground-message-handler w + [('communication-from-ui + c:ui->world + => message) + (transition w (send-message message))])) + (subscribe 'stopper + (message-handlers w + ['stop (transition w + (send-meta-message + (lambda () + (async-channel-put c:world->ui 'stop))) + (unsubscribe 'inbound-relay) + (unsubscribe 'stopper))])))) + (subscribe 'renderer + (message-handlers w + [`(render ,scene) + (transition w + (send-meta-message (lambda () (async-channel-put c:world->ui `(render ,scene)))))] + ['stop (stop w 'renderer)])))) + +(define (make-key-event code) + (cond + [(char? code) (string code)] + [(symbol? code) (symbol->string code)])) + +;; Pinched almost without change from collects/2htdp/private/world.rkt +(define (mouse-event->parts e) + (define x (send e get-x)) + (define y (send e get-y)) + (list 'mouse x y + (cond [(send e button-down?) "button-down"] + [(send e button-up?) "button-up"] + [(send e dragging?) "drag"] + [(send e moving?) "move"] + [(send e entering?) "enter"] + [(send e leaving?) "leave"] + [else ; (send e get-event-type) + (let ([m (send e get-event-type)]) + (error 'on-mouse (format "Unknown event: ~a" m)))]))) + +(define universe-canvas% + (class canvas% + (init-field c:ui->world) + (super-new) + (define/override (on-event e) + (async-channel-put c:ui->world (mouse-event->parts e))) + (define/override (on-char e) + (async-channel-put c:ui->world + (match (make-key-event (send e get-key-code)) + ["release" `(key-up ,(make-key-event (send e get-key-release-code)))] + [other `(key-down ,other)]))))) + +(define (big-bang initial-state . initial-action) + (define c:ui->world (make-async-channel)) + (define c:world->ui (make-async-channel)) + + (define frame (new frame% + [label "os-big-bang universe"] + [width 500] + [height 300])) + (define image (empty-scene 200 200)) + (define canvas (new universe-canvas% + [c:ui->world c:ui->world] + [parent frame] + [paint-callback + (lambda (canvas dc) + (send image draw dc + 0 0 + 0 0 + (send frame get-width) (send frame get-height) + 0 0 + #f))])) + (send frame show #t) + + (thread (lambda () + (let loop () + (define v (async-channel-get c:world->ui)) + (match v + [`(render ,scene) + (set! image scene) + (send frame resize (image-width image) (image-height image)) + (send canvas refresh-now)] + [_ 'ignore]) + (loop)))) + (thread + (lambda () + (ground-vm (apply os-big-bang + initial-state + (ui-actions c:ui->world c:world->ui) + #;(spawn + (os-big-bang 'none + (subscribe 'echoer + (message-handlers w + [any + (transition w + (send-meta-message (lambda () + (write (list any '-> w)) + (newline))))])))) + initial-action)))))