More docs and comments
This commit is contained in:
parent
49b6d0dfb7
commit
b3c2dd96d3
|
@ -69,6 +69,10 @@
|
|||
;; representation of a suspended world and its active subscriptions.
|
||||
(struct world (state subscriptions) #:transparent)
|
||||
|
||||
;; (subscribe/fresh var expr)
|
||||
;; Generates a fresh SID, binds it to var, and results in a
|
||||
;; subscription using that SID with the given expr's
|
||||
;; event-description.
|
||||
(define-syntax subscribe/fresh
|
||||
(syntax-rules ()
|
||||
((_ id-binder event-description)
|
||||
|
@ -84,16 +88,26 @@
|
|||
(match message
|
||||
[pattern body ...] ...))))))
|
||||
|
||||
;; (message-handlers state-pat [pat expr ...] ...)
|
||||
;; When one of these message handlers is invoked, binds the
|
||||
;; world-state value active at the time using state-pat, binds the
|
||||
;; message using pat, and then invokes the exprs. The pat serves
|
||||
;; double-duty: it both destructures the message and acts as a
|
||||
;; predicate controlling receipt of the message.
|
||||
(define-syntax message-handlers
|
||||
(syntax-rules ()
|
||||
((_ old-state-pattern [pattern body ...] ...)
|
||||
(message-handlers* on-message old-state-pattern [pattern body ...] ...))))
|
||||
|
||||
;; As for message-handlers, but builds a meta-message handling
|
||||
;; event-description instead.
|
||||
(define-syntax meta-message-handlers
|
||||
(syntax-rules ()
|
||||
((_ old-state-pattern [pattern body ...] ...)
|
||||
(message-handlers* on-meta-message old-state-pattern [pattern body ...] ...))))
|
||||
|
||||
;; Complex form for writing meta-message handlers at ground level,
|
||||
;; which translate to event handlers. See examples in various drivers.
|
||||
(define-syntax ground-message-handler
|
||||
(syntax-rules (=>)
|
||||
((_ old-state-pattern [(tag-expr evt-expr => pattern) body ...])
|
||||
|
@ -103,6 +117,9 @@
|
|||
(match meta-message
|
||||
[(ground-event-value _ pattern) body ...]))))))
|
||||
|
||||
;; World -> Suspension
|
||||
;; Used to package up our persistent subscriptions into a transient
|
||||
;; os.rkt Suspension.
|
||||
(define (world->os-suspension w)
|
||||
(suspension w
|
||||
#f
|
||||
|
@ -117,14 +134,17 @@
|
|||
(match-define (on-meta-message pattern handler) v)
|
||||
(message-handler pattern (wrap-handler handler)))))
|
||||
|
||||
;; (X WorldState -> Transition) -> X -> WorldState -> Transition
|
||||
(define (((wrap-handler handler) message) w)
|
||||
(maybe-transition->os-transition w (handler message (world-state w))))
|
||||
|
||||
;; World Transition -> KernelModeTransition
|
||||
(define (maybe-transition->os-transition w t)
|
||||
(if (transition? t)
|
||||
(transition->os-transition w t)
|
||||
(transition->os-transition w (transition t '()))))
|
||||
|
||||
;; World (transition WorldState ListOf<Action>) -> KernelModeTransition
|
||||
(define (transition->os-transition w t)
|
||||
(match-define (transition state unflattened-actions) t)
|
||||
(define actions (flatten unflattened-actions))
|
||||
|
@ -136,6 +156,9 @@
|
|||
(for/list [(a actions) #:when (spawn? a)]
|
||||
(spawn-thunk a))))
|
||||
|
||||
;; World WorldState ListOf<Action> -> World
|
||||
;; Updates the World according to the given Actions, and also replaces
|
||||
;; the old with the new WorldState in the result.
|
||||
(define (update-world w new-state actions)
|
||||
(world new-state
|
||||
(foldl (lambda (action old-map)
|
||||
|
@ -150,8 +173,10 @@
|
|||
(world-subscriptions w)
|
||||
actions)))
|
||||
|
||||
;; WorldState [Action ...] -> BootK
|
||||
(define (os-big-bang initial-state . initial-actions)
|
||||
(os-big-bang/transition (transition initial-state initial-actions)))
|
||||
|
||||
;; (transition WorldState ListOf<Action>) -> BootK
|
||||
(define (os-big-bang/transition t)
|
||||
(lambda () (transition->os-transition (world (void) (hash)) t)))
|
||||
|
|
|
@ -1,4 +1,5 @@
|
|||
#lang racket/base
|
||||
;; Some basic drivers and utilities for writing programs using os-userland.rkt
|
||||
|
||||
(require racket/match)
|
||||
(require racket/port)
|
||||
|
@ -29,9 +30,17 @@
|
|||
receive
|
||||
receive/timeout)
|
||||
|
||||
;; BootK -> Void
|
||||
;; Starts the ground VM with the given BootK and a PatternPredicate
|
||||
;; appropriate for use with this library.
|
||||
(define (ground-vm/stdlib boot)
|
||||
(ground-vm boot #:pattern-predicate (lambda (p m) (p m))))
|
||||
|
||||
;; (message-handlers [pat expr ...] ...)
|
||||
;; When one of these message handlers is invoked, binds the message
|
||||
;; using pat, and then invokes the exprs. The pat serves double-duty:
|
||||
;; it both destructures the message and acts as a predicate
|
||||
;; controlling receipt of the message.
|
||||
(define-syntax message-handlers
|
||||
(syntax-rules ()
|
||||
((_ (pattern body ...) ...)
|
||||
|
@ -39,6 +48,8 @@
|
|||
(match-lambda (pattern body ...)))
|
||||
...))))
|
||||
|
||||
;; For matching *ground* events. See also ground-message-handler in
|
||||
;; os-big-bang.rkt.
|
||||
(define-syntax meta-message-handlers
|
||||
(syntax-rules (=>)
|
||||
((_ [(tag-expr evt-expr => pattern) body ...] ...)
|
||||
|
@ -46,6 +57,8 @@
|
|||
(match-lambda ((ground-event-value _ pattern) body ...)))
|
||||
...))))
|
||||
|
||||
;; Any -> Any
|
||||
;; Performs an RPC, according to a simple stereotypical RPC protocol.
|
||||
(define (rpc req)
|
||||
(define reply-addr (gensym 'reply-addr)) ;;; !!! TODO: remove side-effect?
|
||||
(send `(request ,reply-addr ,req))
|
||||
|
@ -53,6 +66,10 @@
|
|||
[`(reply ,(== reply-addr) ,v)
|
||||
v])))
|
||||
|
||||
;; (rpc-service (pat expr ...) ...)
|
||||
;; Starts an RPC service listening for messages matching the
|
||||
;; pats. When one arrives, spawns a new process that runs the
|
||||
;; corresponding exprs, and goes back to listening for more requests.
|
||||
(define-syntax rpc-service
|
||||
(syntax-rules ()
|
||||
[(_ [pattern body ...] ...)
|
||||
|
@ -65,6 +82,7 @@
|
|||
...))
|
||||
(loop))]))
|
||||
|
||||
;; Driver wrapping output to current-output-port.
|
||||
(define display-driver
|
||||
(userland
|
||||
(lambda ()
|
||||
|
@ -75,9 +93,11 @@
|
|||
(flush-output)))
|
||||
(loop)))))
|
||||
|
||||
;; Sends its argument to the display-driver.
|
||||
(define (display x)
|
||||
(send `(display ,x)))
|
||||
|
||||
;; Driver providing an RPC read-line (from current-input-port) service.
|
||||
(define read-line-driver
|
||||
(userland
|
||||
(lambda ()
|
||||
|
@ -89,9 +109,11 @@
|
|||
=> line)
|
||||
line]))]))))
|
||||
|
||||
;; Requests the next line of input.
|
||||
(define (read-line)
|
||||
(rpc 'read-line))
|
||||
|
||||
;; Racket timer event - see comment on the analogous function in os-timer.rkt.
|
||||
(define (time-evt msecs)
|
||||
(wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds))))
|
||||
|
||||
|
@ -106,9 +128,12 @@
|
|||
(wait (message-handlers)
|
||||
(wait-mmh msecs)))
|
||||
|
||||
;; Retrieves the current-inexact-milliseconds, using the VM tree IPC mechanism.
|
||||
(define (current-time)
|
||||
(wait-until-time 0))
|
||||
|
||||
;; RPC service that replies to you when the specified number of
|
||||
;; milliseconds have elapsed.
|
||||
(define sleep-driver
|
||||
(userland
|
||||
(lambda ()
|
||||
|
@ -119,14 +144,18 @@
|
|||
(send `(display "\n"))
|
||||
now]))))
|
||||
|
||||
;; Invoke the sleep-driver.
|
||||
(define (sleep msecs)
|
||||
(rpc `(sleep ,msecs)))
|
||||
|
||||
;; Syntactic sugar for a (wait (message-handlers ...)) combination.
|
||||
(define-syntax receive
|
||||
(syntax-rules ()
|
||||
((_ mh-clause ...)
|
||||
(wait (message-handlers mh-clause ...)))))
|
||||
|
||||
;; Syntactic sugar for a (wait (message-handlers ...)) combination
|
||||
;; with an additional timeout event.
|
||||
(define-syntax receive/timeout
|
||||
(syntax-rules ()
|
||||
((_ timeout-msecs mh-clause ...)
|
||||
|
|
|
@ -1,5 +1,4 @@
|
|||
#lang racket/base
|
||||
|
||||
; Userland for os.rkt: use of delimited continuations to invoke kernel services
|
||||
|
||||
(require racket/match)
|
||||
|
@ -23,8 +22,12 @@
|
|||
|
||||
spawn)
|
||||
|
||||
;; A WaitClause is a (wait-clause PatternPredicate ([Meta]Message -> Any))
|
||||
;; Used to build up what amount to wrapped events in Racket's CMLish
|
||||
;; terminology, for use with wait (which is analogous to sync).
|
||||
(struct wait-clause (pattern handler-proc) #:transparent)
|
||||
|
||||
;; Our internal prompt tag.
|
||||
(define prompt (make-continuation-prompt-tag 'os-userland))
|
||||
|
||||
;; ( -> Void) -> BootK
|
||||
|
@ -81,20 +84,33 @@
|
|||
(define (actions ms mms thrs)
|
||||
(call-in-kernel-context (lambda (k) `(actions ,ms ,mms ,thrs ,k))))
|
||||
|
||||
;; Message -> Void
|
||||
;; Sends a message at this level.
|
||||
(define (send message)
|
||||
(actions (list message) '() '()))
|
||||
|
||||
;; MetaMessage -> Void
|
||||
;; Sends a message at this VM's container's level.
|
||||
(define (meta-send meta-message)
|
||||
(actions '() (list meta-message) '()))
|
||||
|
||||
;; ListOf<Message> [ListOf<MetaMessage>] -> Void
|
||||
;; Sends any number of messages, possibly at multiple levels.
|
||||
(define (send* messages [meta-messages '()])
|
||||
(actions messages meta-messages '()))
|
||||
|
||||
;; ConsTreeOf<WaitClause> [ConsTreeOf<WaitClause>] -> Any
|
||||
;; Synchronizes on a collection of possible events.
|
||||
(define (wait mhs [mmhs '()])
|
||||
(call-in-kernel-context (lambda (k) `(wait #f ,mhs ,mmhs ,k))))
|
||||
|
||||
;; [ConsTreeOf<WaitClause>] [ConsTreeOf<WaitClause>] -> Any
|
||||
;; Synchronizes on a collection of possible events, returning
|
||||
;; "immediately" if none of them are ready to fire.
|
||||
(define (poll [mhs '()] [mmhs '()])
|
||||
(call-in-kernel-context (lambda (k) `(wait #t ,mhs ,mmhs ,k))))
|
||||
|
||||
;; BootK -> Void
|
||||
;; Spawns the given BootK within the current VM.
|
||||
(define (spawn thunk)
|
||||
(actions '() '() (list thunk)))
|
||||
|
|
|
@ -1,5 +1,4 @@
|
|||
#lang racket/base
|
||||
|
||||
;; Compatibility: 2htdp/universe's big-bang expressed in terms of ground-vm and os-big-bang.
|
||||
|
||||
(require racket/match)
|
||||
|
|
Loading…
Reference in New Issue