117 lines
3.5 KiB
Racket
117 lines
3.5 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)
|
|
|
|
ground-vm ;; convenience re-export
|
|
(struct-out ground-event-pattern) ;; convenience re-export
|
|
(struct-out ground-event-value) ;; convenience re-export
|
|
|
|
userland
|
|
|
|
send
|
|
meta-send
|
|
send*
|
|
|
|
wait
|
|
poll
|
|
|
|
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
|
|
;; Wraps a thunk that uses the userland continuation-based approach to
|
|
;; simulating side effects so that it can be used as a BootK with a
|
|
;; KernelModeTransition.
|
|
(define (userland main)
|
|
(lambda ()
|
|
(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)
|
|
(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 (suspension k
|
|
(and polling? (lambda (k) (start-transaction (k void))))
|
|
(wrap-handlers mhs)
|
|
(wrap-handlers mmhs)))]
|
|
[`finish
|
|
(syscall (suspension '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))))
|
|
|
|
;; 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)))
|