From eebab5387b44ca8ed4e3ca7b18aed1a84b0b68bc Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Fri, 20 Jan 2012 18:32:59 -0500 Subject: [PATCH] Switch from one ad-hoc ground language to another, but eliminate HIDs. This removes a bug in the design: metamessages wouldn't have been dispatched properly in more general types of metanetwork than the Racket CMLish framework. --- TODO | 13 +++++ os-big-bang-example.rkt | 9 +++- os-big-bang.rkt | 34 ++++++------- os-example.rkt | 42 +++++++++------- os-udp.rkt | 4 +- os-userland-stdlib.rkt | 14 ++++-- os-userland.rkt | 12 +++-- os.rkt | 108 ++++++++++++++++++++-------------------- universe.rkt | 8 ++- 9 files changed, 140 insertions(+), 104 deletions(-) diff --git a/TODO b/TODO index eab05e7..d7b0afc 100644 --- a/TODO +++ b/TODO @@ -1,3 +1,5 @@ +## DNS + Make RData and RRType the same thing so it becomes impossible to make a mistake. @@ -16,3 +18,14 @@ Tests needed: - looping domain-name (using compressed format) - compressed domain-name pointing into hyperspace - txt record with rdata filled with a list of empty byte-strings + +## os.rkt and friends + + - move from quasiquoted to prefab structs + - define a prefab struct for every evt? that we want to use + - define lowest-level drivers for each prefab struct + +It feels like those lowest-level drivers are listening for *demand* +i.e. they're listening for presence and are then acting to supply such +demand. Think about the relationships between presence (both positive +and negative), and interfacing to ad-hoc sources and sinks. diff --git a/os-big-bang-example.rkt b/os-big-bang-example.rkt index 3dbafd0..9a1be8a 100644 --- a/os-big-bang-example.rkt +++ b/os-big-bang-example.rkt @@ -18,7 +18,9 @@ (transition w (subscribe sid (ground-message-handler w - [((read-line-evt (current-input-port) 'any) => l) + [((list 'read-line reply-addr) + (read-line-evt (current-input-port) 'any) + => l) (transition w (unsubscribe sid) (send-message `(reply ,reply-addr ,l)))])))])) @@ -29,9 +31,12 @@ (define (tick-driver self-sid interval) (let loop ((last-tick-time 0) (counter 0)) + (define next-time (+ last-tick-time interval)) (subscribe self-sid (ground-message-handler w - [((time-evt (+ last-tick-time interval)) => now) + [((list 'timer-alarm next-time) + (time-evt next-time) + => now) (transition w (unsubscribe self-sid) (send-message `(tick ,counter ,now)) diff --git a/os-big-bang.rkt b/os-big-bang.rkt index 5f6f7d8..0dff7f9 100644 --- a/os-big-bang.rkt +++ b/os-big-bang.rkt @@ -80,26 +80,26 @@ (define-syntax ground-message-handler (syntax-rules (=>) - ((_ old-state-pattern [(raw-pattern => pattern) body ...]) - (on-meta-message raw-pattern + ((_ old-state-pattern [(tag-expr evt-expr => pattern) body ...]) + (on-meta-message (ground-event-pattern tag-expr evt-expr) (lambda (meta-message old-state) (match-define old-state-pattern old-state) (match meta-message - [pattern body ...])))))) + [(ground-event-value _ pattern) body ...])))))) -(define (world->os-subscription w) - (subscription w - #f - (for*/list ([(sid vs) (world-subscriptions w)] - [v vs] - #:when (on-message? v)) - (match-define (on-message pattern handler) v) - (message-handler pattern (wrap-handler handler))) - (for*/list ([(sid vs) (world-subscriptions w)] - [v vs] - #:when (on-meta-message? v)) - (match-define (on-meta-message pattern handler) v) - (message-handler pattern (wrap-handler handler))))) +(define (world->os-suspension w) + (suspension w + #f + (for*/list ([(sid vs) (world-subscriptions w)] + [v vs] + #:when (on-message? v)) + (match-define (on-message pattern handler) v) + (message-handler pattern (wrap-handler handler))) + (for*/list ([(sid vs) (world-subscriptions w)] + [v vs] + #:when (on-meta-message? v)) + (match-define (on-meta-message pattern handler) v) + (message-handler pattern (wrap-handler handler))))) (define (((wrap-handler handler) message) w) (maybe-transition->os-transition w (handler message (world-state w)))) @@ -111,7 +111,7 @@ (define (transition->os-transition w t) (match-define (transition state actions) t) - (kernel-mode-transition (world->os-subscription (update-world w state actions)) + (kernel-mode-transition (world->os-suspension (update-world w state actions)) (for/list [(a actions) #:when (send-message? a)] (send-message-body a)) (for/list [(a actions) #:when (send-meta-message? a)] diff --git a/os-example.rkt b/os-example.rkt index a6275a4..579f373 100644 --- a/os-example.rkt +++ b/os-example.rkt @@ -4,19 +4,19 @@ (require racket/pretty) (define (yield k) - (kernel-mode-transition (subscription 'none (lambda (_) (k)) '() '()) + (kernel-mode-transition (suspension 'none (lambda (_) (k)) '() '()) '() '() '())) (define (quit) - (kernel-mode-transition (subscription 'none #f '() '()) + (kernel-mode-transition (suspension 'none #f '() '()) '() '() '())) (define (print x k) - (kernel-mode-transition (subscription 'none (lambda (_) (k)) '() '()) + (kernel-mode-transition (suspension 'none (lambda (_) (k)) '() '()) '() (list (lambda () (pretty-print x))) '())) @@ -25,33 +25,37 @@ (wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds)))) (define (sleep n k) - (kernel-mode-transition (subscription 'none - #f - '() - (list (message-handler - (super-alarm (+ (current-inexact-milliseconds) n)) - (lambda (_message) - (lambda (_state) - (k)))))) + (kernel-mode-transition (suspension 'none + #f + '() + (list (message-handler + (let ((wakeup-time + (+ (current-inexact-milliseconds) n))) + (ground-event-pattern + (list 'alarm wakeup-time) + (super-alarm wakeup-time))) + (lambda (_message) + (lambda (_state) + (k)))))) '() '() '())) (define (spawn thunk k) - (kernel-mode-transition (subscription 'none (lambda (_) (k)) '() '()) + (kernel-mode-transition (suspension 'none (lambda (_) (k)) '() '()) '() '() (list thunk))) (define (example-process delay) (print "SLEEPING" - (lambda () - (sleep delay - (lambda () - (yield - (lambda () - (print "HELLO" - quit)))))))) + (lambda () + (sleep delay + (lambda () + (yield + (lambda () + (print "HELLO" + quit)))))))) (ground-vm (lambda () (spawn (lambda () diff --git a/os-udp.rkt b/os-udp.rkt index b0a5eef..998784f 100644 --- a/os-udp.rkt +++ b/os-udp.rkt @@ -58,7 +58,9 @@ [`(close ,(== sname)) (void)]) (meta-message-handlers - [((udp-receive!-evt s buffer) => (list packet-length host port)) + [((list 'udp-receive sname) + (udp-receive!-evt s buffer) + => (list packet-length host port)) (define packet (subbytes buffer 0 packet-length)) (printf ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>~n~v~n" packet) (dump-bytes! buffer packet-length) diff --git a/os-userland-stdlib.rkt b/os-userland-stdlib.rkt index dfb868c..e815424 100644 --- a/os-userland-stdlib.rkt +++ b/os-userland-stdlib.rkt @@ -41,9 +41,9 @@ (define-syntax meta-message-handlers (syntax-rules (=>) - ((_ [(raw-pattern => pattern) body ...] ...) - (list (wait-clause raw-pattern - (match-lambda (pattern body ...))) + ((_ [(tag-expr evt-expr => pattern) body ...] ...) + (list (wait-clause (ground-event-pattern tag-expr evt-expr) + (match-lambda ((ground-event-value _ pattern) body ...))) ...)))) (define (rpc req) @@ -84,7 +84,9 @@ (rpc-service [`read-line (wait (message-handlers) (meta-message-handlers - [((read-line-evt (current-input-port) 'any) => line) + [('read-line + (read-line-evt (current-input-port) 'any) + => line) line]))])))) (define (read-line) @@ -95,7 +97,9 @@ (define (wait-mmh msecs) (meta-message-handlers - [((time-evt msecs) => current-time) + [((list 'time-evt msecs) + (time-evt msecs) + => current-time) current-time])) (define (wait-until-time msecs) diff --git a/os-userland.rkt b/os-userland.rkt index 7d369bd..2a292ef 100644 --- a/os-userland.rkt +++ b/os-userland.rkt @@ -9,6 +9,8 @@ (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 @@ -55,12 +57,12 @@ (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)))] + (syscall (suspension k + (and polling? (lambda (k) (start-transaction (k void)))) + (wrap-handlers mhs) + (wrap-handlers mmhs)))] [`finish - (syscall (subscription 'finished #f '() '()))])) + (syscall (suspension 'finished #f '() '()))])) (define (((invoke-handler proc) v) k) (start-transaction (k (lambda () (proc v))))) diff --git a/os.rkt b/os.rkt index 2ae2d33..2fdb65b 100644 --- a/os.rkt +++ b/os.rkt @@ -7,7 +7,7 @@ (provide ;; Waiting for messages - (struct-out subscription) + (struct-out suspension) (struct-out message-handler) ;; Kernel requests @@ -18,9 +18,11 @@ vm? run-vm nested-vm + default-pattern-predicate ;; Grounding out the infinite tower of VMs - default-pattern-predicate + (struct-out ground-event-pattern) + (struct-out ground-event-value) ground-vm ) @@ -76,7 +78,8 @@ pending-messages pending-meta-messages pending-processes - pattern-predicate) #:transparent) + pattern-predicate + meta-pattern-predicate) #:transparent) ;; A TrapK is a X -> InterruptK, representing a suspended process ;; waiting for some information from the VM before it can continue. @@ -92,22 +95,12 @@ ;; fresh process or a previously-suspended process just about to ;; resume. -;; A Subscription is a -;; (subscription ProcessState -;; Maybe -;; ListBagOf -;; ListBagOf). -;; To poll the kernel, include a non-#f InterruptK. -(struct subscription (state - k - message-handlers - meta-message-handlers) #:transparent) - ;; A Suspension is a ;; (suspension ProcessState ;; Maybe ;; ListBagOf -;; Map). +;; ListBagOf). +;; To poll the kernel, include a non-#f InterruptK. (struct suspension (state k message-handlers @@ -123,14 +116,14 @@ (struct message-handler (pattern k) #:transparent) ;; A KernelModeTransition is a -;; (kernel-mode-transition Subscription +;; (kernel-mode-transition Suspension ;; 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. -(struct kernel-mode-transition (subscription +;; representing the suspension of 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. +(struct kernel-mode-transition (suspension messages meta-messages new-processes) #:transparent) @@ -145,12 +138,15 @@ ;; TODO: timeouts ;; BootK -> VM -(define (make-vm boot #:pattern-predicate [pattern-predicate default-pattern-predicate]) +(define (make-vm boot + #:pattern-predicate [pattern-predicate default-pattern-predicate] + #:meta-pattern-predicate [meta-pattern-predicate default-pattern-predicate]) (vm (list) (list) (list) (cons boot (list)) - pattern-predicate)) + pattern-predicate + meta-pattern-predicate)) ;; VM -> KernelModeTransition ;; (A kind of Meta-InterruptK) @@ -162,7 +158,7 @@ (meta-handlers (append-map extract-downward-meta-message-handlers (vm-suspensions state))) (poller-k (and (should-poll? state) run-vm)) ;; only block if there's nothing left to do (state (struct-copy vm state [pending-meta-messages (list)]))) - (kernel-mode-transition (subscription state poller-k meta-handlers '()) + (kernel-mode-transition (suspension state poller-k meta-handlers '()) meta-messages '() '()))) @@ -186,40 +182,32 @@ (reverse (vm-pending-messages state)))) (define (extract-downward-meta-message-handlers susp) - (for/list ([(hid mmh) (in-hash (suspension-meta-message-handlers susp))]) - (message-handler (message-handler-pattern mmh) (dispatch-meta-message hid)))) + (for/list ([mmh (suspension-meta-message-handlers susp)]) + (message-handler (message-handler-pattern mmh) (dispatch-meta-message mmh)))) -(define (extract-upward-meta-message-handlers susp) - (for/list ([(hid mmh) (in-hash (suspension-meta-message-handlers susp))]) - (message-handler hid (message-handler-k mmh)))) - -(define (((dispatch-meta-message hid) message) state) +(define (((dispatch-meta-message mmh) message) state) (run-vm (foldl (match-suspension message - (lambda (handler-hid message) (equal? hid handler-hid)) - extract-upward-meta-message-handlers) + (vm-meta-pattern-predicate state) + suspension-meta-message-handlers) (struct-copy vm state [suspensions '()]) (vm-suspensions state)))) ;; KernelModeTransition VM -> VM (define (perform-transition transition state) (match transition - [(kernel-mode-transition new-subscription + [(kernel-mode-transition new-suspension messages meta-messages new-processes) (let* ((state (foldl enqueue-message state messages)) (state (foldl enqueue-runnable state new-processes)) - (state (enqueue-suspension (subscription->suspension new-subscription) state)) + (state (enqueue-suspension new-suspension state)) (state (foldl enqueue-meta-message state meta-messages))) state)] [other (error 'vm "Processes must return a kernel-mode-transition struct; got ~v" other)])) -(define (subscription->suspension sub) - (match-define (subscription ps k mhs mmhs) sub) - (suspension ps k mhs (for/hash ([mmh mmhs]) (values (gensym 'hid) mmh)))) - (define (enqueue-message message state) (struct-copy vm state [pending-messages (cons message (vm-pending-messages state))])) @@ -228,7 +216,7 @@ (define (enqueue-suspension susp state) (match susp - [(suspension _ #f '() (? (lambda (h) (zero? (hash-count h))))) + [(suspension _ #f '() '()) ;; dead process because no continuations offered state] [(suspension _ _ _ _) @@ -269,21 +257,31 @@ (not (null? (vm-pending-messages state))) (ormap suspension-polling? (vm-suspensions state)))) -(define (nested-vm boot #:pattern-predicate [pattern-predicate default-pattern-predicate]) - (lambda () (run-vm (make-vm boot #:pattern-predicate pattern-predicate)))) +(define (nested-vm boot + #:pattern-predicate [pattern-predicate default-pattern-predicate] + #:meta-pattern-predicate [meta-pattern-predicate default-pattern-predicate]) + (lambda () (run-vm (make-vm boot + #:pattern-predicate pattern-predicate + #:meta-pattern-predicate meta-pattern-predicate)))) + +(define default-pattern-predicate + (lambda (p m) (p m))) ;;--------------------------------------------------------------------------- (define (nested-vm-inert? sub) (match sub - [(subscription (vm _ '() '() '() _) #f '() '()) + [(suspension (vm _ '() '() '() _ _) #f '() '()) ;; Inert iff not waiting for any messages or metamessages, and ;; with no internal work left to do. #t] [_ #f])) -(define default-pattern-predicate - (lambda (p m) (p m))) +(struct ground-event-pattern (tag evt) #:transparent) +(struct ground-event-value (tag val) #:transparent) + +(define (match-ground-event p m) + (equal? (ground-event-pattern-tag p) (ground-event-value-tag m))) ;; PatternPredicate ( -> KernelModeTransition ) -> Void ;; In this context, @@ -291,25 +289,29 @@ ;; MessagePattern = evt? ;; MetaMessage, MetaMessagePattern = not defined because there's no outer level ;; Runs its argument VM until it becomes (provably) inert. -(define (ground-vm boot #:pattern-predicate [pattern-predicate default-pattern-predicate]) - (let loop ((transition (run-vm (make-vm boot #:pattern-predicate pattern-predicate)))) +(define (ground-vm boot + #:pattern-predicate [pattern-predicate default-pattern-predicate]) + (let loop ((transition (run-vm (make-vm boot + #:pattern-predicate pattern-predicate + #:meta-pattern-predicate match-ground-event)))) (for-each (lambda (thunk) (thunk)) (kernel-mode-transition-messages transition)) - (when (not (nested-vm-inert? (kernel-mode-transition-subscription transition))) + (when (not (nested-vm-inert? (kernel-mode-transition-suspension transition))) (match transition - [(kernel-mode-transition (subscription new-state - polling-k - message-handlers - '()) + [(kernel-mode-transition (suspension new-state + polling-k + message-handlers + '()) _ '() '()) (define inbound-messages - (map (match-lambda [(message-handler e k) (wrap-evt e (lambda (v) (cons v k)))]) + (map (match-lambda [(message-handler (ground-event-pattern tag evt) k) + (wrap-evt evt (lambda (v) (cons (ground-event-value tag v) k)))]) message-handlers)) (match-define (cons inbound-value inbound-continuation) (apply sync (wrap-evt (if polling-k always-evt never-evt) - (lambda (v) (cons (void) + (lambda (v) (cons (ground-event-value 'idle (void)) (lambda (dummy) polling-k)))) inbound-messages)) (loop ((inbound-continuation inbound-value) new-state))] diff --git a/universe.rkt b/universe.rkt index c823e24..b44d3cf 100644 --- a/universe.rkt +++ b/universe.rkt @@ -59,7 +59,9 @@ (subscribe 'ticker (ground-message-handler (and w (ticker-state counter interval limit)) - [((time-evt next-alarm-time) => now) + [((list 'timer-alarm next-alarm-time) + (time-evt next-alarm-time) + => now) (if (and (positive? limit) (>= counter limit)) (transition w (unsubscribe 'ticker)) (transition (ticker-state (+ counter 1) interval limit) @@ -106,7 +108,9 @@ (spawn (os-big-bang 'none (subscribe 'inbound-relay (ground-message-handler w - [(c:ui->world => message) + [('communication-from-ui + c:ui->world + => message) (transition w (send-message message))])) (subscribe 'stopper (message-handlers w