diff --git a/os-userland-example.rkt b/os-userland-example.rkt new file mode 100644 index 0000000..8aeb91d --- /dev/null +++ b/os-userland-example.rkt @@ -0,0 +1,78 @@ +#lang racket/base + +(require racket/port) +(require "os.rkt") +(require "os-userland.rkt") + +(define (rpc req) + (define reply-addr (gensym 'reply-addr)) ;;; !!! TODO: remove side-effect? + (send `(request ,reply-addr ,req)) + (wait (message-handlers + [`(reply ,(? (lambda (v) (eq? v reply-addr))) ,v) + v]))) + +(define-syntax rpc-service + (syntax-rules () + [(_ pattern body ...) + (let loop () + (wait (message-handlers + [`(request ,reply-addr ,pattern) + (spawn (lambda () + (define answer (begin body ...)) + (send `(reply ,reply-addr ,answer)))) + (loop)])))])) + +(define (display-driver) + (define message (wait (message-handlers [`(display ,message) message]))) + (meta-send (lambda () + (display message) + (flush-output))) + (display-driver)) + +(define (read-line-driver) + (rpc-service `read-line + (wait (message-handlers) + (meta-message-handlers + [((read-line-evt (current-input-port) 'any) => line) + line])))) + +(define (time-evt msecs) + (wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds)))) + +(define (wait-until-time msecs) + (wait (message-handlers) + (meta-message-handlers + [((time-evt msecs) => current-time) + current-time]))) + +(define (current-time) + (wait-until-time 0)) + +(define (sleep-driver) + (rpc-service `(sleep ,msecs) + (send `(display (Sleeping ,msecs))) + (wait (message-handlers) + (meta-message-handlers + [((time-evt (+ (current-time) msecs)) => now) + (send `(display "\n")) + now])))) + +(define (main) + (spawn display-driver) + (spawn read-line-driver) + (spawn sleep-driver) + (spawn (lambda () + (send `(display "HI\n")) + (rpc `(sleep 1000)) + (send `(display "THERE\n")))) + (poll) + (send `(display "Hello! Enter your name:\n")) + (define name (rpc 'read-line)) + (send `(display "Hello, ")) + (send `(display ,name)) + (send `(display "!\n")) + (rpc `(sleep 1000)) + (send `(display "Goodbye\n"))) + +(ground-vm (lambda (p m) (p m)) ;; pattern-predicate + (lambda () (userland main))) diff --git a/os-userland.rkt b/os-userland.rkt new file mode 100644 index 0000000..5eae414 --- /dev/null +++ b/os-userland.rkt @@ -0,0 +1,107 @@ +#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) + message-handlers + meta-message-handlers + userland + + send + meta-send + send* + + wait + poll + + spawn) + +(struct wait-clause (pattern handler-proc) #:transparent) + +(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 (=>) + ((_ [(raw-pattern => pattern) body ...] ...) + (list (wait-clause raw-pattern + (match-lambda (pattern body ...))) + ...)))) + +(define prompt (make-continuation-prompt-tag 'os-userland)) + +(define (userland main) + (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) + (map (lambda (t) (runnable (void) (lambda (_) (userland t)))) + (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 (subscription k + (and polling? (lambda (k) (start-transaction (k void)))) + (wrap-handlers mhs) + (wrap-handlers mmhs)))] + [`finish + (syscall (subscription '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)))