From 21cc52f4b0571d416e1430b82b2390bde6fcb0d9 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 3 May 2012 15:09:08 -0400 Subject: [PATCH 1/4] Keep track of metaroles; add debug names --- os2-udp.rkt | 6 ++- os2.rkt | 148 +++++++++++++++++++++++++++++++++++----------------- 2 files changed, 104 insertions(+), 50 deletions(-) diff --git a/os2-udp.rkt b/os2-udp.rkt index 88e3838..21b1552 100644 --- a/os2-udp.rkt +++ b/os2-udp.rkt @@ -62,7 +62,8 @@ [(set-member? active-handles local-addr) active-handles] [else (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 (topic-subscriber (handle-mapping (wild) (wild)) #:virtual? #t) #:state active-handles @@ -96,7 +97,8 @@ (when (eq? state 'socket-is-open) (spawn (lambda (dummy-pid) (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-send-to s remote-host remote-port body) state]) diff --git a/os2.rkt b/os2.rkt index d5b4f35..9f2c1d7 100644 --- a/os2.rkt +++ b/os2.rkt @@ -93,7 +93,8 @@ ;; A QuasiQueue is a list of Xs in *reversed* order. -(struct vm (processes ;; Hash +(struct vm (name ;; Any - for debugging complex VM trees + processes ;; Hash endpoints ;; Hash next-process-id ;; PID pending-actions ;; QuasiQueue<(cons PID Action)> @@ -104,9 +105,10 @@ ;; topic) in a conversation. (struct endpoint (id topics handlers) #:transparent) -;; A Process is an Exists State . (process PID State Set), -;; representing a VM process and its collection of active endpoints. -(struct process (id state endpoints) #:transparent) +;; A Process is an Exists State . (process Any PID State Set +;; Set), representing a VM process and its collection of active +;; 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 ;; role in a conversation. @@ -137,8 +139,8 @@ ;; (send-message Any Role) (struct send-message (body role) #:prefab) ;; -;; (spawn BootK Maybe>) -(struct spawn (main k) #:prefab) +;; (spawn BootK Maybe> Any) +(struct spawn (main k debug-name) #:prefab) ;; ;; (kill Maybe Any) (struct kill (pid reason) #:prefab) @@ -194,7 +196,7 @@ (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-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 (extend-transition t . more-actions) @@ -248,11 +250,12 @@ ;;--------------------------------------------------------------------------- ;; Core virtualizable virtual machine. -(define (make-vm boot) - (vm (hash) +(define (make-vm name boot) + (vm name + (hash) (hash) 0 - (list (cons -1 (spawn boot #f))))) + (list (cons -1 (spawn boot #f 'primordial-process))))) (define (run-vm state) (let loop ((remaining-actions (reverse (vm-pending-actions state))) @@ -267,22 +270,32 @@ [(cons (cons pid action) rest) (match action [(at-meta-level preaction) - (define transformed-preaction (transform-meta-action pid preaction)) - (loop rest state (cons transformed-preaction outbound-actions))] + (let-values (((transformed-preaction state) (transform-meta-action pid preaction state))) + (loop rest state (cons transformed-preaction outbound-actions)))] [(yield k) (loop rest (run-ready state pid k) outbound-actions)] [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) (null? (vm-pending-actions 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 [processes (for/hash ([(pid p) (in-hash (vm-processes state))] - #:when (or (not (set-empty? (process-endpoints p))) - (ormap (lambda (entry) (= (car entry) pid)) - (vm-pending-actions state)))) + #:when (or (process-alive? pid p) + (begin (printf "~a PID ~v (~a) garbage-collected~n" + (vm-name state) + pid + (process-name p)) + #f))) (values pid p))])) (define (send-to-user failure-proc f . args) @@ -299,11 +312,16 @@ (define (perform-action pid preaction state) (match preaction - [(add-role pre-eid topics hs) (do-subscribe pid pre-eid (ensure-topic-union topics) hs state)] - [(delete-role pre-eid reason) (do-unsubscribe pid pre-eid reason state)] - [(send-message body role) (route-and-deliver role body state)] - [(spawn main k) (do-spawn pid main k state)] - [(kill pid-to-kill reason) (do-kill (or pid-to-kill pid) reason state)])) + [(add-role pre-eid topics hs) + (values '() (do-subscribe pid pre-eid (ensure-topic-union topics) hs state))] + [(delete-role pre-eid reason) + (values '() (do-unsubscribe pid pre-eid 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) (cond @@ -322,9 +340,15 @@ (define ((add-process-eid new-eid) p) (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) (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) (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) (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-name (or debug-name new-pid)) (match-define (transition initial-state initial-actions) (cond [(procedure? main) (send-to-user (lambda (e) (transition #f (kill #f e))) main new-pid)] [(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 (struct-copy vm (enqueue-actions state new-pid initial-actions) [processes (hash-set (vm-processes state) new-pid initial-process)] [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)) -(define (print-kill pid-to-kill reason) +(define (print-kill vm-name pid-to-kill process-name reason) (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) - (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)] - [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) (cond [(hash-has-key? (vm-processes state) pid-to-kill) - (print-kill pid-to-kill reason) - (define dying-endpoints (process-endpoints (hash-ref (vm-processes state) pid-to-kill))) - (let* ((state (for/fold ([state state]) ([eid (in-set dying-endpoints)]) - (do-unsubscribe pid-to-kill (eid-pre-eid eid) reason state)))) - (struct-copy vm state [processes (hash-remove (vm-processes state) pid-to-kill)]))] - [else state])) + (define dying-process (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 (process-endpoints dying-process))]) + (do-unsubscribe pid-to-kill (eid-pre-eid eid) reason state))) + (new-outbound-actions (for/list ([eid (in-set (process-meta-endpoints dying-process))]) + (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) (if trap-k @@ -472,28 +512,40 @@ [pending-actions (append (reverse flat-actions) (vm-pending-actions 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 [(add-role pre-eid topics hs) - (add-role (eid pid pre-eid) - topics - (handlers (wrap-trapk pid (handlers-presence hs)) - (wrap-trapk pid (handlers-absence hs)) - (wrap-trapk pid (handlers-message hs))))] + (define new-eid (eid pid pre-eid)) + (values (add-role new-eid + topics + (handlers (wrap-trapk pid (handlers-presence 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 (eid pid pre-eid) reason)] - [(? send-message? p) p] - [(spawn main k) - (spawn main (wrap-trapk pid k))] - [(? kill? p) p])) + (define old-eid (eid pid pre-eid)) + (values (delete-role old-eid reason) + (if (hash-has-key? (vm-processes state) pid) + (generic-update-process state pid (remove-process-meta-eid old-eid)) + 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) - (lambda (self-pid) (run-vm (make-vm boot)))) +(define (nested-vm name boot) + (lambda (self-pid) (run-vm (make-vm name boot)))) (define (ground-vm boot) - (let loop ((state (make-vm boot))) + (let loop ((state (make-vm 'ground-vm boot))) (match (run-vm state) [(transition state actions) (define is-blocking? From 9cf91bb231418ff79731321ebb86ecb854e66865 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 3 May 2012 16:30:43 -0400 Subject: [PATCH 2/4] Bind non-listener handles too. --- os2-udp.rkt | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/os2-udp.rkt b/os2-udp.rkt index 21b1552..ff337d0 100644 --- a/os2-udp.rkt +++ b/os2-udp.rkt @@ -72,10 +72,16 @@ [(topic _ (handle-mapping local-addr socket) _) (transition (set-remove active-handles local-addr))])))) +(define (bind-socket! s local-addr) + (cond + [(udp-listener? local-addr) (udp-bind! s #f (udp-listener-port local-addr))] + [(udp-handle? local-addr) (udp-bind! s #f 0)] + [else (void)])) + ;; UdpAddress -> BootK (define ((udp-socket-manager local-addr) self-pid) (define s (udp-open-socket #f #f)) - (when (udp-listener? local-addr) (udp-bind! s #f (udp-listener-port local-addr))) + (bind-socket! s local-addr) (define buffer (make-bytes 65536)) ;; TODO: buffer size control (transition 'socket-is-open ;; Offers a handle-mapping on the local network so that the From 7bb49752f49ed8c2547955be0f06e85c49dbc450 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 3 May 2012 16:31:05 -0400 Subject: [PATCH 3/4] role/fresh macro --- indenting2.el | 2 +- os2.rkt | 5 +++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/indenting2.el b/indenting2.el index 095c1a2..f6b60c0 100644 --- a/indenting2.el +++ b/indenting2.el @@ -3,4 +3,4 @@ (mapcar #'(lambda (x) (put x 'scheme-indent-function 1)) '(transition extend-transition)) (mapcar #'(lambda (x) (put x 'scheme-indent-function 2)) - '(role yield))) + '(role role/fresh yield))) diff --git a/os2.rkt b/os2.rkt index 9f2c1d7..89b9c21 100644 --- a/os2.rkt +++ b/os2.rkt @@ -23,6 +23,7 @@ extend-transition role + role/fresh (except-out (struct-out add-role) add-role) (rename-out [make-add-role add-role]) (except-out (struct-out delete-role) delete-role) @@ -186,6 +187,10 @@ topics-expr (handlers presence-handler absence-handler message-handler)))]))) +(define-syntax-rule (role/fresh pre-eid-var rest ...) + (let ((pre-eid-var (gensym 'role))) + (role pre-eid-var rest ...))) + (define-syntax-rule (yield-macro #:state state-pattern body ...) (yield (match-lambda [state-pattern body ...]))) From cca7971b55e8d59cee5889144d66fc803864a9a2 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 3 May 2012 16:31:17 -0400 Subject: [PATCH 4/4] current-ground-transition, for debugging --- os2.rkt | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/os2.rkt b/os2.rkt index 89b9c21..7a561e5 100644 --- a/os2.rkt +++ b/os2.rkt @@ -58,7 +58,10 @@ non-wild? ;; Reexports from racket/match for convenience - (all-from-out racket/match)) + (all-from-out racket/match) + + ;; For debugging + current-ground-transition) ;; Endpoints are the units of deduplication. ;; Flows (in canonical form) are the units of presence. @@ -551,7 +554,7 @@ (define (ground-vm boot) (let loop ((state (make-vm 'ground-vm boot))) - (match (run-vm state) + (match (let ((t (run-vm state))) (set! current-ground-transition t) t) [(transition state actions) (define is-blocking? (match actions @@ -578,3 +581,5 @@ (wrap-evt always-evt (lambda (dummy) values))) active-events))) (loop (interruptk state))))]))) + +(define current-ground-transition #f) \ No newline at end of file