Keep track of metaroles; add debug names
This commit is contained in:
parent
8f10b2ad4d
commit
21cc52f4b0
|
@ -62,7 +62,8 @@
|
||||||
[(set-member? active-handles local-addr) active-handles]
|
[(set-member? active-handles local-addr) active-handles]
|
||||||
[else
|
[else
|
||||||
(transition (set-add active-handles local-addr)
|
(transition (set-add active-handles local-addr)
|
||||||
(spawn (udp-socket-manager local-addr)))])]))
|
(spawn (udp-socket-manager local-addr)
|
||||||
|
#:debug-name (list 'udp-socket local-addr)))])]))
|
||||||
(role 'handle-mapping-reaper
|
(role 'handle-mapping-reaper
|
||||||
(topic-subscriber (handle-mapping (wild) (wild)) #:virtual? #t)
|
(topic-subscriber (handle-mapping (wild) (wild)) #:virtual? #t)
|
||||||
#:state active-handles
|
#:state active-handles
|
||||||
|
@ -96,7 +97,8 @@
|
||||||
(when (eq? state 'socket-is-open)
|
(when (eq? state 'socket-is-open)
|
||||||
(spawn (lambda (dummy-pid)
|
(spawn (lambda (dummy-pid)
|
||||||
(udp-close s)
|
(udp-close s)
|
||||||
(transition 'dummy (kill))))))
|
(transition 'dummy (kill)))
|
||||||
|
#:debug-name (list 'udp-socket-closer local-addr))))
|
||||||
[(udp-packet (== local-addr) (udp-address remote-host remote-port) body)
|
[(udp-packet (== local-addr) (udp-address remote-host remote-port) body)
|
||||||
(udp-send-to s remote-host remote-port body)
|
(udp-send-to s remote-host remote-port body)
|
||||||
state])
|
state])
|
||||||
|
|
148
os2.rkt
148
os2.rkt
|
@ -93,7 +93,8 @@
|
||||||
|
|
||||||
;; A QuasiQueue<X> is a list of Xs in *reversed* order.
|
;; A QuasiQueue<X> is a list of Xs in *reversed* order.
|
||||||
|
|
||||||
(struct vm (processes ;; Hash<PID, Process>
|
(struct vm (name ;; Any - for debugging complex VM trees
|
||||||
|
processes ;; Hash<PID, Process>
|
||||||
endpoints ;; Hash<EID, Endpoint>
|
endpoints ;; Hash<EID, Endpoint>
|
||||||
next-process-id ;; PID
|
next-process-id ;; PID
|
||||||
pending-actions ;; QuasiQueue<(cons PID Action)>
|
pending-actions ;; QuasiQueue<(cons PID Action)>
|
||||||
|
@ -104,9 +105,10 @@
|
||||||
;; topic) in a conversation.
|
;; topic) in a conversation.
|
||||||
(struct endpoint (id topics handlers) #:transparent)
|
(struct endpoint (id topics handlers) #:transparent)
|
||||||
|
|
||||||
;; A Process is an Exists State . (process PID State Set<EID>),
|
;; A Process is an Exists State . (process Any PID State Set<EID>
|
||||||
;; representing a VM process and its collection of active endpoints.
|
;; Set<EID>), representing a VM process and its collection of active
|
||||||
(struct process (id state endpoints) #:transparent)
|
;; endpoints at this level and at the VM's container's level.
|
||||||
|
(struct process (name id state endpoints meta-endpoints) #:transparent)
|
||||||
|
|
||||||
;; A Topic is a (topic Role Pattern Boolean), describing an Endpoint's
|
;; A Topic is a (topic Role Pattern Boolean), describing an Endpoint's
|
||||||
;; role in a conversation.
|
;; role in a conversation.
|
||||||
|
@ -137,8 +139,8 @@
|
||||||
;; (send-message Any Role)
|
;; (send-message Any Role)
|
||||||
(struct send-message (body role) #:prefab)
|
(struct send-message (body role) #:prefab)
|
||||||
;;
|
;;
|
||||||
;; (spawn BootK Maybe<TrapK<PID>>)
|
;; (spawn BootK Maybe<TrapK<PID>> Any)
|
||||||
(struct spawn (main k) #:prefab)
|
(struct spawn (main k debug-name) #:prefab)
|
||||||
;;
|
;;
|
||||||
;; (kill Maybe<PID> Any)
|
;; (kill Maybe<PID> Any)
|
||||||
(struct kill (pid reason) #:prefab)
|
(struct kill (pid reason) #:prefab)
|
||||||
|
@ -194,7 +196,7 @@
|
||||||
(define make-add-role add-role) ;; no special treatment required at present
|
(define make-add-role add-role) ;; no special treatment required at present
|
||||||
(define (make-delete-role pre-eid [reason #f]) (delete-role pre-eid reason))
|
(define (make-delete-role pre-eid [reason #f]) (delete-role pre-eid reason))
|
||||||
(define (make-send-message body [role 'publisher]) (send-message body role))
|
(define (make-send-message body [role 'publisher]) (send-message body role))
|
||||||
(define (make-spawn main [k #f]) (spawn main k))
|
(define (make-spawn main [k #f] #:debug-name [debug-name #f]) (spawn main k debug-name))
|
||||||
(define (make-kill [pid #f] #:reason [reason #f]) (kill pid reason))
|
(define (make-kill [pid #f] #:reason [reason #f]) (kill pid reason))
|
||||||
|
|
||||||
(define (extend-transition t . more-actions)
|
(define (extend-transition t . more-actions)
|
||||||
|
@ -248,11 +250,12 @@
|
||||||
;;---------------------------------------------------------------------------
|
;;---------------------------------------------------------------------------
|
||||||
;; Core virtualizable virtual machine.
|
;; Core virtualizable virtual machine.
|
||||||
|
|
||||||
(define (make-vm boot)
|
(define (make-vm name boot)
|
||||||
(vm (hash)
|
(vm name
|
||||||
|
(hash)
|
||||||
(hash)
|
(hash)
|
||||||
0
|
0
|
||||||
(list (cons -1 (spawn boot #f)))))
|
(list (cons -1 (spawn boot #f 'primordial-process)))))
|
||||||
|
|
||||||
(define (run-vm state)
|
(define (run-vm state)
|
||||||
(let loop ((remaining-actions (reverse (vm-pending-actions state)))
|
(let loop ((remaining-actions (reverse (vm-pending-actions state)))
|
||||||
|
@ -267,22 +270,32 @@
|
||||||
[(cons (cons pid action) rest)
|
[(cons (cons pid action) rest)
|
||||||
(match action
|
(match action
|
||||||
[(at-meta-level preaction)
|
[(at-meta-level preaction)
|
||||||
(define transformed-preaction (transform-meta-action pid preaction))
|
(let-values (((transformed-preaction state) (transform-meta-action pid preaction state)))
|
||||||
(loop rest state (cons transformed-preaction outbound-actions))]
|
(loop rest state (cons transformed-preaction outbound-actions)))]
|
||||||
[(yield k)
|
[(yield k)
|
||||||
(loop rest (run-ready state pid k) outbound-actions)]
|
(loop rest (run-ready state pid k) outbound-actions)]
|
||||||
[preaction
|
[preaction
|
||||||
(loop rest (perform-action pid preaction state) outbound-actions)])])))
|
(let-values (((new-outbound-actions-rev state) (perform-action pid preaction state)))
|
||||||
|
(loop rest state (append new-outbound-actions-rev outbound-actions)))])])))
|
||||||
|
|
||||||
(define (vm-idle? state)
|
(define (vm-idle? state)
|
||||||
(null? (vm-pending-actions state)))
|
(null? (vm-pending-actions state)))
|
||||||
|
|
||||||
(define (collect-dead-processes state)
|
(define (collect-dead-processes state)
|
||||||
|
;; dns-read-driver is being collected because it only has a metarole.%%%
|
||||||
|
(define (process-alive? pid p)
|
||||||
|
(or (not (set-empty? (process-endpoints p)))
|
||||||
|
(not (set-empty? (process-meta-endpoints p)))
|
||||||
|
(ormap (lambda (entry) (= (car entry) pid))
|
||||||
|
(vm-pending-actions state))))
|
||||||
(struct-copy vm state
|
(struct-copy vm state
|
||||||
[processes (for/hash ([(pid p) (in-hash (vm-processes state))]
|
[processes (for/hash ([(pid p) (in-hash (vm-processes state))]
|
||||||
#:when (or (not (set-empty? (process-endpoints p)))
|
#:when (or (process-alive? pid p)
|
||||||
(ormap (lambda (entry) (= (car entry) pid))
|
(begin (printf "~a PID ~v (~a) garbage-collected~n"
|
||||||
(vm-pending-actions state))))
|
(vm-name state)
|
||||||
|
pid
|
||||||
|
(process-name p))
|
||||||
|
#f)))
|
||||||
(values pid p))]))
|
(values pid p))]))
|
||||||
|
|
||||||
(define (send-to-user failure-proc f . args)
|
(define (send-to-user failure-proc f . args)
|
||||||
|
@ -299,11 +312,16 @@
|
||||||
|
|
||||||
(define (perform-action pid preaction state)
|
(define (perform-action pid preaction state)
|
||||||
(match preaction
|
(match preaction
|
||||||
[(add-role pre-eid topics hs) (do-subscribe pid pre-eid (ensure-topic-union topics) hs state)]
|
[(add-role pre-eid topics hs)
|
||||||
[(delete-role pre-eid reason) (do-unsubscribe pid pre-eid reason state)]
|
(values '() (do-subscribe pid pre-eid (ensure-topic-union topics) hs state))]
|
||||||
[(send-message body role) (route-and-deliver role body state)]
|
[(delete-role pre-eid reason)
|
||||||
[(spawn main k) (do-spawn pid main k state)]
|
(values '() (do-unsubscribe pid pre-eid reason state))]
|
||||||
[(kill pid-to-kill reason) (do-kill (or pid-to-kill pid) reason state)]))
|
[(send-message body role)
|
||||||
|
(values '() (route-and-deliver role body state))]
|
||||||
|
[(spawn main k debug-name)
|
||||||
|
(values '() (do-spawn pid main k debug-name state))]
|
||||||
|
[(kill pid-to-kill reason)
|
||||||
|
(do-kill (or pid-to-kill pid) reason state)]))
|
||||||
|
|
||||||
(define (do-subscribe pid pre-eid topics hs state)
|
(define (do-subscribe pid pre-eid topics hs state)
|
||||||
(cond
|
(cond
|
||||||
|
@ -322,9 +340,15 @@
|
||||||
(define ((add-process-eid new-eid) p)
|
(define ((add-process-eid new-eid) p)
|
||||||
(struct-copy process p [endpoints (set-add (process-endpoints p) new-eid)]))
|
(struct-copy process p [endpoints (set-add (process-endpoints p) new-eid)]))
|
||||||
|
|
||||||
|
(define ((add-process-meta-eid new-eid) p)
|
||||||
|
(struct-copy process p [meta-endpoints (set-add (process-meta-endpoints p) new-eid)]))
|
||||||
|
|
||||||
(define ((remove-process-eid old-eid) p)
|
(define ((remove-process-eid old-eid) p)
|
||||||
(struct-copy process p [endpoints (set-remove (process-endpoints p) old-eid)]))
|
(struct-copy process p [endpoints (set-remove (process-endpoints p) old-eid)]))
|
||||||
|
|
||||||
|
(define ((remove-process-meta-eid old-eid) p)
|
||||||
|
(struct-copy process p [meta-endpoints (set-remove (process-meta-endpoints p) old-eid)]))
|
||||||
|
|
||||||
(define (install-endpoint state new-eid new-endpoint)
|
(define (install-endpoint state new-eid new-endpoint)
|
||||||
(struct-copy vm state [endpoints (hash-set (vm-endpoints state) new-eid new-endpoint)]))
|
(struct-copy vm state [endpoints (hash-set (vm-endpoints state) new-eid new-endpoint)]))
|
||||||
|
|
||||||
|
@ -394,36 +418,52 @@
|
||||||
(match-define (endpoint (eid pid _) _ (handlers _ _ message-handler)) e)
|
(match-define (endpoint (eid pid _) _ (handlers _ _ message-handler)) e)
|
||||||
(run-trapk state pid message-handler message-topic body)))
|
(run-trapk state pid message-handler message-topic body)))
|
||||||
|
|
||||||
(define (do-spawn spawning-pid main k state)
|
(define (do-spawn spawning-pid main k debug-name state)
|
||||||
(define new-pid (vm-next-process-id state))
|
(define new-pid (vm-next-process-id state))
|
||||||
|
(define new-name (or debug-name new-pid))
|
||||||
(match-define (transition initial-state initial-actions)
|
(match-define (transition initial-state initial-actions)
|
||||||
(cond
|
(cond
|
||||||
[(procedure? main) (send-to-user (lambda (e) (transition #f (kill #f e))) main new-pid)]
|
[(procedure? main) (send-to-user (lambda (e) (transition #f (kill #f e))) main new-pid)]
|
||||||
[(transition? main) main]))
|
[(transition? main) main]))
|
||||||
(define initial-process (process new-pid initial-state (set)))
|
(define initial-process (process new-name new-pid initial-state (set) (set)))
|
||||||
(define spawned-state
|
(define spawned-state
|
||||||
(struct-copy vm (enqueue-actions state new-pid initial-actions)
|
(struct-copy vm (enqueue-actions state new-pid initial-actions)
|
||||||
[processes (hash-set (vm-processes state) new-pid initial-process)]
|
[processes (hash-set (vm-processes state) new-pid initial-process)]
|
||||||
[next-process-id (+ new-pid 1)]))
|
[next-process-id (+ new-pid 1)]))
|
||||||
|
(printf "~a PID ~v (~a) started~n" (vm-name state) new-pid new-name)
|
||||||
(run-trapk spawned-state spawning-pid k new-pid))
|
(run-trapk spawned-state spawning-pid k new-pid))
|
||||||
|
|
||||||
(define (print-kill pid-to-kill reason)
|
(define (print-kill vm-name pid-to-kill process-name reason)
|
||||||
(cond
|
(cond
|
||||||
[(eq? reason #f) (printf "PID ~v exited normally~n" pid-to-kill)]
|
[(eq? reason #f) (printf "~a PID ~v (~a) exited normally~n"
|
||||||
|
vm-name
|
||||||
|
pid-to-kill
|
||||||
|
process-name)]
|
||||||
[(exn? reason) ((error-display-handler)
|
[(exn? reason) ((error-display-handler)
|
||||||
(format "PID ~v exited with exception~n~a" pid-to-kill (exn-message reason))
|
(format "~a PID ~v (~a) exited with exception~n~a"
|
||||||
|
vm-name
|
||||||
|
pid-to-kill
|
||||||
|
process-name
|
||||||
|
(exn-message reason))
|
||||||
reason)]
|
reason)]
|
||||||
[else (printf "PID ~v exited with reason: ~a~n" pid-to-kill reason)]))
|
[else (printf "~a PID ~v (~a) exited with reason: ~a~n"
|
||||||
|
vm-name
|
||||||
|
pid-to-kill
|
||||||
|
process-name
|
||||||
|
reason)]))
|
||||||
|
|
||||||
(define (do-kill pid-to-kill reason state)
|
(define (do-kill pid-to-kill reason state)
|
||||||
(cond
|
(cond
|
||||||
[(hash-has-key? (vm-processes state) pid-to-kill)
|
[(hash-has-key? (vm-processes state) pid-to-kill)
|
||||||
(print-kill pid-to-kill reason)
|
(define dying-process (hash-ref (vm-processes state) pid-to-kill))
|
||||||
(define dying-endpoints (process-endpoints (hash-ref (vm-processes state) pid-to-kill)))
|
(print-kill (vm-name state) pid-to-kill (process-name dying-process) reason)
|
||||||
(let* ((state (for/fold ([state state]) ([eid (in-set dying-endpoints)])
|
(let* ((state (for/fold ([state state]) ([eid (in-set (process-endpoints dying-process))])
|
||||||
(do-unsubscribe pid-to-kill (eid-pre-eid eid) reason state))))
|
(do-unsubscribe pid-to-kill (eid-pre-eid eid) reason state)))
|
||||||
(struct-copy vm state [processes (hash-remove (vm-processes state) pid-to-kill)]))]
|
(new-outbound-actions (for/list ([eid (in-set (process-meta-endpoints dying-process))])
|
||||||
[else state]))
|
(delete-role eid reason))))
|
||||||
|
(values new-outbound-actions
|
||||||
|
(struct-copy vm state [processes (hash-remove (vm-processes state) pid-to-kill)])))]
|
||||||
|
[else (values '() state)]))
|
||||||
|
|
||||||
(define (run-trapk state pid trap-k . args)
|
(define (run-trapk state pid trap-k . args)
|
||||||
(if trap-k
|
(if trap-k
|
||||||
|
@ -472,28 +512,40 @@
|
||||||
[pending-actions (append (reverse flat-actions) (vm-pending-actions state))]))
|
[pending-actions (append (reverse flat-actions) (vm-pending-actions state))]))
|
||||||
|
|
||||||
(define (((wrap-trapk pid trapk) . args) state)
|
(define (((wrap-trapk pid trapk) . args) state)
|
||||||
(apply run-trapk state pid trapk args))
|
(if (hash-has-key? (vm-processes state) pid)
|
||||||
|
(run-vm (apply run-trapk state pid trapk args))
|
||||||
|
state))
|
||||||
|
|
||||||
(define (transform-meta-action pid preaction)
|
(define (transform-meta-action pid preaction state)
|
||||||
(match preaction
|
(match preaction
|
||||||
[(add-role pre-eid topics hs)
|
[(add-role pre-eid topics hs)
|
||||||
(add-role (eid pid pre-eid)
|
(define new-eid (eid pid pre-eid))
|
||||||
topics
|
(values (add-role new-eid
|
||||||
(handlers (wrap-trapk pid (handlers-presence hs))
|
topics
|
||||||
(wrap-trapk pid (handlers-absence hs))
|
(handlers (wrap-trapk pid (handlers-presence hs))
|
||||||
(wrap-trapk pid (handlers-message hs))))]
|
(wrap-trapk pid (handlers-absence hs))
|
||||||
|
(wrap-trapk pid (handlers-message hs))))
|
||||||
|
(if (hash-has-key? (vm-processes state) pid)
|
||||||
|
(generic-update-process state pid (add-process-meta-eid new-eid))
|
||||||
|
state))]
|
||||||
[(delete-role pre-eid reason)
|
[(delete-role pre-eid reason)
|
||||||
(delete-role (eid pid pre-eid) reason)]
|
(define old-eid (eid pid pre-eid))
|
||||||
[(? send-message? p) p]
|
(values (delete-role old-eid reason)
|
||||||
[(spawn main k)
|
(if (hash-has-key? (vm-processes state) pid)
|
||||||
(spawn main (wrap-trapk pid k))]
|
(generic-update-process state pid (remove-process-meta-eid old-eid))
|
||||||
[(? kill? p) p]))
|
state))]
|
||||||
|
[(? send-message? p)
|
||||||
|
(values p state)]
|
||||||
|
[(spawn main k debug-name)
|
||||||
|
(values (spawn main (wrap-trapk pid k) debug-name) state)]
|
||||||
|
[(? kill? p)
|
||||||
|
(values p state)]))
|
||||||
|
|
||||||
(define (nested-vm boot)
|
(define (nested-vm name boot)
|
||||||
(lambda (self-pid) (run-vm (make-vm boot))))
|
(lambda (self-pid) (run-vm (make-vm name boot))))
|
||||||
|
|
||||||
(define (ground-vm boot)
|
(define (ground-vm boot)
|
||||||
(let loop ((state (make-vm boot)))
|
(let loop ((state (make-vm 'ground-vm boot)))
|
||||||
(match (run-vm state)
|
(match (run-vm state)
|
||||||
[(transition state actions)
|
[(transition state actions)
|
||||||
(define is-blocking?
|
(define is-blocking?
|
||||||
|
|
Loading…
Reference in New Issue