Split from racket-dns at 0bd5bb093501261fcea90156b26fbe73867b5cbd
This commit is contained in:
Tony Garnock-Jones
commit
1f1eb5f548
|
|
@ -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.
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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))
|
||||
|
|
@ -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)
|
||||
|
|
@ -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"))
|
||||
|
|
@ -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<Action>) 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<SID,Set<EventDescription>>), 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)))
|
||||
|
|
@ -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)))))
|
||||
|
|
@ -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)))])))]))))
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)]))))))
|
||||
|
|
@ -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)))))
|
||||
|
|
@ -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))
|
||||
|
|
@ -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)))))
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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
|
||||
|
|
@ -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<Suspension>
|
||||
;; QueueOf<Message> ;; TODO: make unordered?
|
||||
;; QueueOf<MetaMessage> ;; TODO: make unordered?
|
||||
;; QueueOf<BootK>).
|
||||
(struct vm (suspensions
|
||||
pending-messages
|
||||
pending-meta-messages
|
||||
pending-processes
|
||||
pattern-predicate
|
||||
meta-pattern-predicate) #:transparent)
|
||||
|
||||
;; A TrapK<X> 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<InterruptK>
|
||||
;; ListBagOf<MessageHandler>
|
||||
;; ListBagOf<MetaMessageHandler>).
|
||||
;; 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<Message>)
|
||||
(struct message-handler (pattern k) #:transparent)
|
||||
|
||||
;; A KernelModeTransition is a
|
||||
;; (kernel-mode-transition Suspension
|
||||
;; ListBagOf<Message>
|
||||
;; ListBagOf<MetaMessage>
|
||||
;; ListBagOf<BootK>)
|
||||
;; 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<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
|
||||
(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")]))))
|
||||
|
|
@ -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)))))
|
||||
Loading…
Reference in New Issue