From af4cb501047689bc2d1c2907ea58660d41421902 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Mon, 16 Jan 2012 17:38:00 -0500 Subject: [PATCH] Make userland spawn raw by default, for better interop between it and big-bang --- os-udp-test-big-bang.rkt | 6 ++--- os-udp-test-userland.rkt | 27 ++++++++++--------- os-udp.rkt | 24 +++++++++-------- os-userland-example.rkt | 10 +++---- os-userland-stdlib.rkt | 57 ++++++++++++++++++++++------------------ os-userland.rkt | 25 +++++++++--------- 6 files changed, 79 insertions(+), 70 deletions(-) diff --git a/os-udp-test-big-bang.rkt b/os-udp-test-big-bang.rkt index 17b7745..9f5c2eb 100644 --- a/os-udp-test-big-bang.rkt +++ b/os-udp-test-big-bang.rkt @@ -38,8 +38,8 @@ (ground-vm (os-big-bang 'none (spawn spy) - (spawn (lambda () (userland udp-driver))) + (spawn udp-driver) (spawn echoer)))) -;;(main) -(provide main) +(main) +;;(provide main) diff --git a/os-udp-test-userland.rkt b/os-udp-test-userland.rkt index dcba424..02eb83a 100644 --- a/os-udp-test-userland.rkt +++ b/os-udp-test-userland.rkt @@ -4,16 +4,17 @@ (require "os-userland-stdlib.rkt") (require "os-udp.rkt") -(ground-vm/userland/stdlib - (lambda () - (spawn display-driver) - (spawn read-line-driver) - (spawn udp-driver) - (poll) - (define s (rpc `(udp new 5555 65536))) - (let loop () - (wait (message-handlers - [(udp-packet source (and sink (== s)) body) - (write `(udp (source ,source) (sink ,sink))) (newline) - (send (udp-packet sink source body)) - (loop)]))))) \ No newline at end of file +(ground-vm/stdlib + (userland + (lambda () + (spawn display-driver) + (spawn read-line-driver) + (spawn udp-driver) + (poll) + (define s (rpc `(udp new 5555 65536))) + (let loop () + (wait (message-handlers + [(udp-packet source (and sink (== s)) body) + (write `(udp (source ,source) (sink ,sink))) (newline) + (send (udp-packet sink source body)) + (loop)])))))) \ No newline at end of file diff --git a/os-udp.rkt b/os-udp.rkt index 2f2f76b..b0a5eef 100644 --- a/os-udp.rkt +++ b/os-udp.rkt @@ -24,17 +24,19 @@ ;; TODO: BUG?: Routing packets between two local sockets won't work ;; because the patterns aren't set up to recognise that situation. -(define (udp-driver) - (rpc-service - [`(udp new ,port-number ,buffer-size) - (define s (udp-open-socket #f #f)) - (when port-number - (udp-bind! s #f port-number)) - (define sname (udp-address #f port-number)) - (spawn (udp-sender sname s)) - (spawn (udp-receiver sname s buffer-size)) - (spawn (udp-closer sname s)) - sname])) +(define udp-driver + (userland + (lambda () + (rpc-service + [`(udp new ,port-number ,buffer-size) + (define s (udp-open-socket #f #f)) + (when port-number + (udp-bind! s #f port-number)) + (define sname (udp-address #f port-number)) + (spawn (userland (udp-sender sname s))) + (spawn (userland (udp-receiver sname s buffer-size))) + (spawn (userland (udp-closer sname s))) + sname])))) (define ((udp-sender sname s)) (let loop () diff --git a/os-userland-example.rkt b/os-userland-example.rkt index 8a59257..af45920 100644 --- a/os-userland-example.rkt +++ b/os-userland-example.rkt @@ -6,10 +6,10 @@ (spawn display-driver) (spawn read-line-driver) (spawn sleep-driver) - (spawn (lambda () - (display "HI\n") - (sleep 1000) - (display "THERE\n"))) + (spawn (userland (lambda () + (display "HI\n") + (sleep 1000) + (display "THERE\n")))) (poll) ;; Wait for drivers to become ready (!) ;; The Right Way to do this is to have presence integrated with subscription (display "Hello! Enter your name:\n") @@ -20,4 +20,4 @@ (sleep 1000) (display "Goodbye\n")) -(ground-vm/userland/stdlib main) +(ground-vm/stdlib (userland main)) diff --git a/os-userland-stdlib.rkt b/os-userland-stdlib.rkt index b216645..dfb868c 100644 --- a/os-userland-stdlib.rkt +++ b/os-userland-stdlib.rkt @@ -8,7 +8,7 @@ (provide (all-from-out "os-userland.rkt") - ground-vm/userland/stdlib + ground-vm/stdlib message-handlers meta-message-handlers @@ -29,8 +29,8 @@ receive receive/timeout) -(define (ground-vm/userland/stdlib boot) - (ground-vm/userland boot #:pattern-predicate (lambda (p m) (p m)))) +(define (ground-vm/stdlib boot) + (ground-vm boot #:pattern-predicate (lambda (p m) (p m)))) (define-syntax message-handlers (syntax-rules () @@ -59,28 +59,33 @@ (let loop () (wait (message-handlers [`(request ,reply-addr ,pattern) - (spawn (lambda () - (define answer (let () body ...)) - (send `(reply ,reply-addr ,answer))))] + (spawn (userland (lambda () + (define answer (let () body ...)) + (send `(reply ,reply-addr ,answer)))))] ...)) (loop))])) -(define (display-driver) - (define message (wait (message-handlers [`(display ,message) message]))) - (meta-send (lambda () - (base:display message) - (flush-output))) - (display-driver)) +(define display-driver + (userland + (lambda () + (let loop () + (define message (wait (message-handlers [`(display ,message) message]))) + (meta-send (lambda () + (base:display message) + (flush-output))) + (loop))))) (define (display x) (send `(display ,x))) -(define (read-line-driver) - (rpc-service - [`read-line (wait (message-handlers) - (meta-message-handlers - [((read-line-evt (current-input-port) 'any) => line) - line]))])) +(define read-line-driver + (userland + (lambda () + (rpc-service + [`read-line (wait (message-handlers) + (meta-message-handlers + [((read-line-evt (current-input-port) 'any) => line) + line]))])))) (define (read-line) (rpc 'read-line)) @@ -100,13 +105,15 @@ (define (current-time) (wait-until-time 0)) -(define (sleep-driver) - (rpc-service - [`(sleep ,msecs) - (send `(display (Sleeping ,msecs))) - (define now (wait-until-time (+ (current-time) msecs))) - (send `(display "\n")) - now])) +(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])))) (define (sleep msecs) (rpc `(sleep ,msecs))) diff --git a/os-userland.rkt b/os-userland.rkt index 5401650..7d369bd 100644 --- a/os-userland.rkt +++ b/os-userland.rkt @@ -8,8 +8,9 @@ (provide (struct-out wait-clause) + ground-vm ;; convenience re-export + userland - ground-vm/userland send meta-send @@ -18,21 +19,22 @@ wait poll - spawn - spawn-raw) + spawn) (struct wait-clause (pattern handler-proc) #:transparent) (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) - (start-transaction ((reply-to (lambda (_) - (main) - 'finish)) - void))) - -(define (ground-vm/userland boot #:pattern-predicate [pattern-predicate default-pattern-predicate]) - (ground-vm (lambda () (userland boot)) #:pattern-predicate pattern-predicate)) + (lambda () + (start-transaction ((reply-to (lambda (_) + (main) + 'finish)) + void)))) (define ((reply-to k) v) (call-with-continuation-prompt (lambda () (k (v))) prompt)) @@ -93,7 +95,4 @@ (call-in-kernel-context (lambda (k) `(wait #t ,mhs ,mmhs ,k)))) (define (spawn thunk) - (spawn-raw (lambda () (userland thunk)))) - -(define (spawn-raw thunk) (actions '() '() (list thunk)))