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

Remove struct runnable; provide default pattern-predicate; make os-big-bang virtualizable

This commit is contained in:
Tony Garnock-Jones 2012-01-13 16:42:03 -05:00
parent 28452b10f3
commit 1fae9c95e3
6 changed files with 60 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

18
os-big-bang.rkt
View File

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

5
os-example.rkt
View File

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

2
os-userland-stdlib.rkt
View File

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

6
os-userland.rkt
View File

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

28
os.rkt
View File

@ -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<Suspension>
;; QueueOf<Message> ;; TODO: make unordered?
;; QueueOf<MetaMessage> ;; TODO: make unordered?
;; QueueOf<Runnable>).
;; QueueOf<BootK>).
(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<Message>
;; ListBagOf<MetaMessage>
;; ListBagOf<Runnable>)
;; 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.
@ -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)))