diff --git a/os-big-bang-example.rkt b/os-big-bang-example.rkt index 83ffe8d..5ddade1 100644 --- a/os-big-bang-example.rkt +++ b/os-big-bang-example.rkt @@ -37,35 +37,37 @@ (send-message `(tick ,counter ,now)) (loop now (+ counter 1)))])))) -(os-big-bang 'none - (subscribe 'display-driver display-driver-handler) - (subscribe 'read-line-driver read-line-driver-handler) - (tick-driver 'ticker 1000) - (send-message 'greet-loop) - (subscribe 'greet-loop-handler - (message-handlers w - ['greet-loop - (transition w - (send-message `(display "Hello! Enter your name:\n")) - (send-message `(request read-name read-line)))])) - (subscribe 'ticker-handler - (message-handlers w - [`(tick ,counter ,_) - (transition w - (send-message - `(display ,(string-append "TICK " - (number->string counter) - "\n"))))])) - (subscribe 'read-line-result-handler - (message-handlers w - [`(reply read-name ,(== eof)) - (transition w - (send-message `(display "Goodbye!\n")))] - [`(reply read-name ,name) - (transition w - (send-message `(display "Hello, ")) - (send-message `(display ,name)) - (send-message `(display "!\n")) - (unsubscribe 'ticker) - (send-message 'greet-loop) - )]))) +(ground-vm + (os-big-bang 'none + (subscribe 'display-driver display-driver-handler) + (subscribe 'read-line-driver read-line-driver-handler) + (tick-driver 'ticker 1000) + (send-message `(display "Hello! ")) + (send-message 'greet-loop) + (subscribe 'greet-loop-handler + (message-handlers w + ['greet-loop + (transition w + (send-message `(display "Enter your name:\n")) + (send-message `(request read-name read-line)))])) + (subscribe 'ticker-handler + (message-handlers w + [`(tick ,counter ,_) + (transition w + (send-message + `(display ,(string-append "TICK " + (number->string counter) + "\n"))))])) + (subscribe 'read-line-result-handler + (message-handlers w + [`(reply read-name ,(== eof)) + (transition w + (send-message `(display "Goodbye!\n")))] + [`(reply read-name ,name) + (transition w + (send-message `(display "Hello, ")) + (send-message `(display ,name)) + (send-message `(display "!\n")) + (unsubscribe 'ticker) + (send-message 'greet-loop) + )])))) diff --git a/os-big-bang.rkt b/os-big-bang.rkt index da2e4e1..bffdd93 100644 --- a/os-big-bang.rkt +++ b/os-big-bang.rkt @@ -20,6 +20,7 @@ (except-out (struct-out transition) transition) (rename-out [make-transition transition]) + ground-vm ;; reprovided from os.rkt for convenience os-big-bang) ;; A SID is an Any, a world-specific identifier for subscriptions. @@ -120,16 +121,9 @@ (define (spawn->runnable s) (match-define (spawn initial-state initial-actions) s) - (runnable (void) - (lambda (_) (boot-task initial-state initial-actions)))) + (apply os-big-bang initial-state initial-actions)) -(define (boot-task initial-state initial-actions) - (transition->os-transition (world (void) (hash)) - (transition initial-state initial-actions))) - -(define (os-big-bang initial-state - #:pattern-predicate [pattern-predicate (lambda (p m) (p m))] - . initial-actions) - (ground-vm pattern-predicate - (lambda () - (boot-task initial-state initial-actions)))) +(define (os-big-bang initial-state . initial-actions) + (lambda () + (transition->os-transition (world (void) (hash)) + (transition initial-state initial-actions)))) diff --git a/os-example.rkt b/os-example.rkt index ccede1f..a6275a4 100644 --- a/os-example.rkt +++ b/os-example.rkt @@ -41,7 +41,7 @@ (kernel-mode-transition (subscription 'none (lambda (_) (k)) '() '()) '() '() - (list (runnable 'none (lambda (_) (thunk)))))) + (list thunk))) (define (example-process delay) (print "SLEEPING" @@ -53,8 +53,7 @@ (print "HELLO" quit)))))))) -(ground-vm (lambda (p m) (p m)) - (lambda () +(ground-vm (lambda () (spawn (lambda () (example-process 1000)) (lambda () diff --git a/os-userland-stdlib.rkt b/os-userland-stdlib.rkt index 74e8253..d29563b 100644 --- a/os-userland-stdlib.rkt +++ b/os-userland-stdlib.rkt @@ -30,7 +30,7 @@ receive/timeout) (define (ground-vm/userland/stdlib boot) - (ground-vm/userland (lambda (p m) (p m)) boot)) + (ground-vm/userland boot #:pattern-predicate (lambda (p m) (p m)))) (define-syntax message-handlers (syntax-rules () diff --git a/os-userland.rkt b/os-userland.rkt index be45b2b..cf012bd 100644 --- a/os-userland.rkt +++ b/os-userland.rkt @@ -30,8 +30,8 @@ 'finish)) void))) -(define (ground-vm/userland pattern-predicate boot) - (ground-vm pattern-predicate (lambda () (userland boot)))) +(define (ground-vm/userland boot #:pattern-predicate [pattern-predicate default-pattern-predicate]) + (ground-vm (lambda () (userland boot)) #:pattern-predicate pattern-predicate)) (define ((reply-to k) v) (call-with-continuation-prompt (lambda () (k (v))) prompt)) @@ -44,7 +44,7 @@ (kernel-mode-transition sub (reverse messages) (reverse meta-messages) - (map (lambda (t) (runnable (void) (lambda (_) (userland t)))) + (map (lambda (t) (lambda () (userland t))) (reverse new-threads)))) (match action [`(actions ,ms ,mms ,thrs ,k) diff --git a/os.rkt b/os.rkt index 6f65c6b..abc3d14 100644 --- a/os.rkt +++ b/os.rkt @@ -7,9 +7,6 @@ (require "functional-queue.rkt") (provide - ;; Spawning processes - (struct-out runnable) - ;; Waiting for messages (struct-out subscription) (struct-out message-handler) @@ -23,6 +20,7 @@ run-vm ;; Grounding out the infinite tower of VMs + default-pattern-predicate ground-vm ) @@ -73,7 +71,7 @@ ;; A VM is a (vm ListBagOf ;; QueueOf ;; TODO: make unordered? ;; QueueOf ;; TODO: make unordered? -;; QueueOf). +;; QueueOf). (struct vm (suspensions pending-messages pending-meta-messages @@ -90,9 +88,9 @@ ;; the process, and the output is the information passed back to the ;; VM when the process yields the CPU. -;; A Runnable is a (runnable ProcessState InterruptK), representing a -;; temporarily-suspended runnable process. -(struct runnable (state k) #:transparent) +;; A BootK is a ( -> KernelModeTransition), representing either a +;; fresh process or a previously-suspended process just about to +;; resume. ;; A Subscription is a ;; (subscription ProcessState @@ -128,7 +126,7 @@ ;; (kernel-mode-transition Subscription ;; ListBagOf ;; ListBagOf -;; ListBagOf) +;; ListBagOf) ;; representing the subscription for the transitioning process, a list ;; of messages to emit at both this VM's and its container's level, ;; and a list of new processes to create and schedule. @@ -146,12 +144,12 @@ ;; TODO: enforce user-mode restrictions ;; TODO: timeouts -;; PatternPredicate ( -> KernelModeTransition ) -> VM +;; PatternPredicate BootK -> VM (define (make-vm pattern-predicate boot) (vm (list) (make-queue) (make-queue) - (enqueue (make-queue) (runnable (void) (lambda (dummy) (boot)))) + (enqueue (make-queue) boot) pattern-predicate)) ;; VM -> KernelModeTransition @@ -172,15 +170,14 @@ (define (requeue-pollers state) (foldl (lambda (susp state) (if (suspension-polling? susp) - (enqueue-runnable (runnable (suspension-state susp) - (suspension-k susp)) + (enqueue-runnable (lambda () ((suspension-k susp) (suspension-state susp))) state) (enqueue-suspension susp state))) (struct-copy vm state [suspensions '()]) (vm-suspensions state))) (define (run-runnables state) - (foldl (lambda (r state) (perform-transition ((runnable-k r) (runnable-state r)) state)) + (foldl (lambda (r state) (perform-transition (r) state)) (struct-copy vm state [pending-processes (make-queue)]) (queue->list (vm-pending-processes state)))) @@ -283,13 +280,16 @@ #t] [_ #f])) +(define default-pattern-predicate + (lambda (p m) (p m))) + ;; PatternPredicate ( -> KernelModeTransition ) -> Void ;; In this context, ;; Message = a thunk ;; MessagePattern = evt? ;; MetaMessage, MetaMessagePattern = not defined because there's no outer level ;; Runs its argument VM until it becomes (provably) inert. -(define (ground-vm pattern-predicate boot) +(define (ground-vm boot #:pattern-predicate [pattern-predicate default-pattern-predicate]) (let loop ((transition (run-vm (make-vm pattern-predicate boot)))) (for-each (lambda (thunk) (thunk)) (kernel-mode-transition-messages transition)) (when (not (nested-vm-inert? (kernel-mode-transition-subscription transition)))