diff --git a/os-big-bang.rkt b/os-big-bang.rkt index e8603d4..39e87c1 100644 --- a/os-big-bang.rkt +++ b/os-big-bang.rkt @@ -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) -> 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 -> 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) -> BootK (define (os-big-bang/transition t) (lambda () (transition->os-transition (world (void) (hash)) t))) diff --git a/os-userland-stdlib.rkt b/os-userland-stdlib.rkt index e815424..fd21b39 100644 --- a/os-userland-stdlib.rkt +++ b/os-userland-stdlib.rkt @@ -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 ...) diff --git a/os-userland.rkt b/os-userland.rkt index 2a292ef..a963205 100644 --- a/os-userland.rkt +++ b/os-userland.rkt @@ -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 [ListOf] -> Void +;; Sends any number of messages, possibly at multiple levels. (define (send* messages [meta-messages '()]) (actions messages meta-messages '())) +;; ConsTreeOf [ConsTreeOf] -> Any +;; Synchronizes on a collection of possible events. (define (wait mhs [mmhs '()]) (call-in-kernel-context (lambda (k) `(wait #f ,mhs ,mmhs ,k)))) +;; [ConsTreeOf] [ConsTreeOf] -> 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))) diff --git a/universe.rkt b/universe.rkt index b44d3cf..871b69a 100644 --- a/universe.rkt +++ b/universe.rkt @@ -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)