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

Make nested-vm and ground-vm able to take actions instead of transition, for stateless boot processes

This commit is contained in:
Tony Garnock-Jones 2012-07-23 17:42:18 -04:00
parent 1c42aea271
commit 3a2ea7b026
4 changed files with 30 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
chat-os2-paper.rkt
View File

@ -12,13 +12,13 @@
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define listener-proc (define listener
(transition 'no-state (nested-vm
(at-meta-level (at-meta-level
(role (tcp-listener 5999) (role (tcp-listener 5999)
#:topic t #:topic t
#:on-presence #:on-presence
(spawn (connection-handler t)))))) (spawn (connection-handler t))))))
(define (connection-handler t) (define (connection-handler t)
(define me (gensym 'user)) (define me (gensym 'user))
@ -71,7 +71,6 @@
`(,me says ,line)))]))) `(,me says ,line)))])))
(ground-vm (ground-vm
(transition 'no-state (spawn tcp-driver)
(spawn tcp-driver) (spawn listener))
(spawn (nested-vm listener-proc))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

14
chat-os2.rkt
View File

@ -7,14 +7,12 @@
(define (main) (define (main)
(ground-vm (ground-vm
(transition 'no-state (spawn tcp-driver)
(spawn tcp-driver) (spawn (nested-vm #:debug-name 'chat-vm
(spawn (nested-vm #:debug-name 'chat-vm (at-meta-level
(transition 'no-state (role (tcp-listener 5999)
(at-meta-level #:topic t
(role (tcp-listener 5999) #:on-presence (spawn (connection-handler t))))))))
#:topic t
#:on-presence (spawn (connection-handler t))))))))))
(define (connection-handler t) (define (connection-handler t)
(match-define (topic _ (tcp-channel connection-id _ _) _) t) (match-define (topic _ (tcp-channel connection-id _ _) _) t)

11
os2-nested-example.rkt
View File

@ -36,10 +36,9 @@
(spawn (spy 'ground-spy)) (spawn (spy 'ground-spy))
(when event-at-ground? (eventing-process 'ground-level-eventing-process)) (when event-at-ground? (eventing-process 'ground-level-eventing-process))
(spawn (nested-vm #:debug-name (debug-name 'nested-vm) (spawn (nested-vm #:debug-name (debug-name 'nested-vm)
(transition 'no-state (spawn (spy 'nested-spy))
(spawn (spy 'nested-spy)) (when install-relay? (spawn event-relay
(when install-relay? (spawn event-relay #:debug-name 'event-relay))
#:debug-name 'event-relay)) (when (not event-at-ground?)
(when (not event-at-ground?) (eventing-process 'nested-eventing-process)))
(eventing-process 'nested-eventing-process))))
#:debug-name (debug-name 'nested-vm))))) #:debug-name (debug-name 'nested-vm)))))

14
os2.rkt
View File

@ -429,6 +429,12 @@
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
;; Core virtualizable virtual machine. ;; Core virtualizable virtual machine.
(define (vm-boot-parameters->boot-specification params)
(match params
[(list (? transition? t)) t]
[(list (? procedure? p)) p]
[(? list? actions) (transition (void) actions)]))
(define (make-vm name boot) (define (make-vm name boot)
(vm name (vm name
(hash) (hash)
@ -761,19 +767,19 @@
[(_ (~or (~optional (~seq #:debug-name debug-name) #:name "#:debug-name of nested-vm") [(_ (~or (~optional (~seq #:debug-name debug-name) #:name "#:debug-name of nested-vm")
(~optional (~seq #:pid pid) #:name "#:pid variable name")) (~optional (~seq #:pid pid) #:name "#:pid variable name"))
... ...
boot-expr) boot-param ...)
#`(nested-vm-proc #,(if (attribute debug-name) #`(nested-vm-proc #,(if (attribute debug-name)
#'debug-name #'debug-name
#'(gensym 'nested-vm)) #'(gensym 'nested-vm))
(lambda (#,(if (attribute pid) #'pid #'dummy-pid)) (lambda (#,(if (attribute pid) #'pid #'dummy-pid))
boot-expr))]))) (vm-boot-parameters->boot-specification (list boot-param ...))))])))
(define (nested-vm-proc name boot) (define (nested-vm-proc name boot)
(boot-specification (lambda (self-pid) (run-vm (make-vm name boot))) (boot-specification (lambda (self-pid) (run-vm (make-vm name boot)))
vm?)) vm?))
(define (ground-vm boot) (define (ground-vm . boot-params)
(let loop ((state (make-vm 'ground-vm boot))) (let loop ((state (make-vm 'ground-vm (vm-boot-parameters->boot-specification boot-params))))
(match (let ((t (run-vm state))) (set! current-ground-transition t) t) (match (let ((t (run-vm state))) (set! current-ground-transition t) t)
[(transition state actions) [(transition state actions)
(define is-blocking? (define is-blocking?