113 lines
3.0 KiB
Racket
113 lines
3.0 KiB
Racket
#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
|
|
ground-vm/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 (ground-vm/userland pattern-predicate boot)
|
|
(ground-vm pattern-predicate (lambda () (userland boot))))
|
|
|
|
(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)))
|