diff --git a/examples/chat-paper.rkt b/examples/chat-paper.rkt index 8bc50f2..6453faa 100644 --- a/examples/chat-paper.rkt +++ b/examples/chat-paper.rkt @@ -2,10 +2,12 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (spawn-vm + #:debug-name 'listener-vm (at-meta-level (observe-publishers (tcp-channel ? (tcp-listener 5999) ?) (match-conversation (tcp-channel them us _) - (on-presence (spawn (chat-session them us))))))) + (on-presence (name-process `(,them --> ,us) + (spawn (chat-session them us)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (chat-session them us) diff --git a/ground.rkt b/ground.rkt index 5a67aba..118b948 100644 --- a/ground.rkt +++ b/ground.rkt @@ -19,8 +19,24 @@ (provide run-ground-vm) +(require/typed profile + [profile-thunk ((-> Void) #:custom-key (Pairof + (Continuation-Mark-Keyof Any) + (-> (Listof Any) (Listof Any))) + -> Void)]) + (: run-ground-vm : process-spec -> Void) (define (run-ground-vm boot) + (profile-thunk (lambda () (run-ground-vm* boot)) + #:custom-key (cons marketplace-continuation-mark-key + (lambda: ([vs : (Listof Any)]) + (let: loop : (Listof Any) ((vs : (Listof Any) vs)) + (if (null? vs) + '() + (cons vs (loop (cdr vs))))))))) + +(: run-ground-vm* : process-spec -> Void) +(define (run-ground-vm* boot) (let loop ((state (make-vm boot))) (match (run-vm state) [(transition state actions) diff --git a/process.rkt b/process.rkt index 518eb93..03e0b0f 100644 --- a/process.rkt +++ b/process.rkt @@ -12,7 +12,10 @@ action-tree->quasiqueue quit-interruptk run-ready - notify-route-change-vm) + notify-route-change-vm + marketplace-continuation-mark-key) + +(define marketplace-continuation-mark-key (make-continuation-mark-key 'marketplace)) (define-syntax-rule (send-to-user p (e) failure-result enclosed-expr) (send-to-user* (process-debug-name p) (process-pid p) (e) failure-result enclosed-expr)) @@ -26,7 +29,9 @@ debug-name pid e)) failure-result)]) (marketplace-log 'debug "Entering process ~v(~v)" debug-name pid) - (define result enclosed-expr) + (define result (with-continuation-mark marketplace-continuation-mark-key + (or debug-name pid) + enclosed-expr)) (marketplace-log 'debug "Leaving process ~v(~v)" debug-name pid) result))