Experimental integration with Vincent's custom profiling tools

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)

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)

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))