syndicate-lang
/
racket-dns-2012
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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.
This commit is contained in:
Tony Garnock-Jones 2012-01-20 18:32:59 -05:00
parent 1dcf34bd56
commit eebab5387b
9 changed files with 140 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
TODO
View File

@ -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.

9
os-big-bang-example.rkt
View File

@ -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))

34
os-big-bang.rkt
View File

@ -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)]

42
os-example.rkt
View File

@ -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 ()

4
os-udp.rkt
View File

@ -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)

14
os-userland-stdlib.rkt
View File

@ -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)

12
os-userland.rkt
View File

@ -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)))))

108
os.rkt
View File

@ -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<X> 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<InterruptK>
;; ListBagOf<MessageHandler>
;; ListBagOf<MetaMessageHandler>).
;; 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<InterruptK>
;; ListBagOf<MessageHandler>
;; Map<HID,MetaMessageHandler>).
;; ListBagOf<MetaMessageHandler>).
;; 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<Message>
;; ListBagOf<MetaMessage>
;; ListBagOf<BootK>)
;; 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))]

8
universe.rkt
View File

@ -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