Make nested-vm and ground-vm able to take actions instead of transition, for stateless boot processes
This commit is contained in:
parent
1c42aea271
commit
3a2ea7b026
|
@ -12,13 +12,13 @@
|
|||
;;---------------------------------------------------------------------------
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define listener-proc
|
||||
(transition 'no-state
|
||||
(at-meta-level
|
||||
(role (tcp-listener 5999)
|
||||
#:topic t
|
||||
#:on-presence
|
||||
(spawn (connection-handler t))))))
|
||||
(define listener
|
||||
(nested-vm
|
||||
(at-meta-level
|
||||
(role (tcp-listener 5999)
|
||||
#:topic t
|
||||
#:on-presence
|
||||
(spawn (connection-handler t))))))
|
||||
|
||||
(define (connection-handler t)
|
||||
(define me (gensym 'user))
|
||||
|
@ -71,7 +71,6 @@
|
|||
`(,me says ,line)))])))
|
||||
|
||||
(ground-vm
|
||||
(transition 'no-state
|
||||
(spawn tcp-driver)
|
||||
(spawn (nested-vm listener-proc))))
|
||||
(spawn tcp-driver)
|
||||
(spawn listener))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
14
chat-os2.rkt
14
chat-os2.rkt
|
@ -7,14 +7,12 @@
|
|||
|
||||
(define (main)
|
||||
(ground-vm
|
||||
(transition 'no-state
|
||||
(spawn tcp-driver)
|
||||
(spawn (nested-vm #:debug-name 'chat-vm
|
||||
(transition 'no-state
|
||||
(at-meta-level
|
||||
(role (tcp-listener 5999)
|
||||
#:topic t
|
||||
#:on-presence (spawn (connection-handler t))))))))))
|
||||
(spawn tcp-driver)
|
||||
(spawn (nested-vm #:debug-name 'chat-vm
|
||||
(at-meta-level
|
||||
(role (tcp-listener 5999)
|
||||
#:topic t
|
||||
#:on-presence (spawn (connection-handler t))))))))
|
||||
|
||||
(define (connection-handler t)
|
||||
(match-define (topic _ (tcp-channel connection-id _ _) _) t)
|
||||
|
|
|
@ -36,10 +36,9 @@
|
|||
(spawn (spy 'ground-spy))
|
||||
(when event-at-ground? (eventing-process 'ground-level-eventing-process))
|
||||
(spawn (nested-vm #:debug-name (debug-name 'nested-vm)
|
||||
(transition 'no-state
|
||||
(spawn (spy 'nested-spy))
|
||||
(when install-relay? (spawn event-relay
|
||||
#:debug-name 'event-relay))
|
||||
(when (not event-at-ground?)
|
||||
(eventing-process 'nested-eventing-process))))
|
||||
(spawn (spy 'nested-spy))
|
||||
(when install-relay? (spawn event-relay
|
||||
#:debug-name 'event-relay))
|
||||
(when (not event-at-ground?)
|
||||
(eventing-process 'nested-eventing-process)))
|
||||
#:debug-name (debug-name 'nested-vm)))))
|
||||
|
|
14
os2.rkt
14
os2.rkt
|
@ -429,6 +429,12 @@
|
|||
;;---------------------------------------------------------------------------
|
||||
;; 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)
|
||||
(vm name
|
||||
(hash)
|
||||
|
@ -761,19 +767,19 @@
|
|||
[(_ (~or (~optional (~seq #:debug-name debug-name) #:name "#:debug-name of nested-vm")
|
||||
(~optional (~seq #:pid pid) #:name "#:pid variable name"))
|
||||
...
|
||||
boot-expr)
|
||||
boot-param ...)
|
||||
#`(nested-vm-proc #,(if (attribute debug-name)
|
||||
#'debug-name
|
||||
#'(gensym 'nested-vm))
|
||||
(lambda (#,(if (attribute pid) #'pid #'dummy-pid))
|
||||
boot-expr))])))
|
||||
(vm-boot-parameters->boot-specification (list boot-param ...))))])))
|
||||
|
||||
(define (nested-vm-proc name boot)
|
||||
(boot-specification (lambda (self-pid) (run-vm (make-vm name boot)))
|
||||
vm?))
|
||||
|
||||
(define (ground-vm boot)
|
||||
(let loop ((state (make-vm 'ground-vm boot)))
|
||||
(define (ground-vm . boot-params)
|
||||
(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)
|
||||
[(transition state actions)
|
||||
(define is-blocking?
|
||||
|
|
Loading…
Reference in New Issue