164 lines
4.4 KiB
Racket
164 lines
4.4 KiB
Racket
#lang racket/base
|
|
;; Some basic drivers and utilities for writing programs using os-userland.rkt
|
|
|
|
(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)
|
|
|
|
;; 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 ...) ...)
|
|
(list (wait-clause (match-lambda (pattern #t) (_ #f))
|
|
(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 ...] ...)
|
|
(list (wait-clause (ground-event-pattern tag-expr evt-expr)
|
|
(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))
|
|
(wait (message-handlers
|
|
[`(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 ...] ...)
|
|
(let loop ()
|
|
(wait (message-handlers
|
|
[`(request ,reply-addr ,pattern)
|
|
(spawn (userland (lambda ()
|
|
(define answer (let () body ...))
|
|
(send `(reply ,reply-addr ,answer)))))]
|
|
...))
|
|
(loop))]))
|
|
|
|
;; Driver wrapping output to current-output-port.
|
|
(define display-driver
|
|
(userland
|
|
(lambda ()
|
|
(let loop ()
|
|
(define message (wait (message-handlers [`(display ,message) message])))
|
|
(meta-send (lambda ()
|
|
(base:display message)
|
|
(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 ()
|
|
(rpc-service
|
|
[`read-line (wait (message-handlers)
|
|
(meta-message-handlers
|
|
[('read-line
|
|
(read-line-evt (current-input-port) 'any)
|
|
=> 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))))
|
|
|
|
(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)))
|
|
|
|
;; 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 ()
|
|
(rpc-service
|
|
[`(sleep ,msecs)
|
|
(send `(display (Sleeping ,msecs)))
|
|
(define now (wait-until-time (+ (current-time) msecs)))
|
|
(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 ...)
|
|
(wait (message-handlers mh-clause ...)
|
|
(wait-mmh timeout-msecs)))))
|