Compare commits

...

2 Commits

Author SHA1 Message Date
Tony Garnock-Jones a48f886509 Profile both process-accounting and regular call-stack 2014-03-09 15:44:40 -04:00
Tony Garnock-Jones 6e3b8be397 Experimental integration with Vincent's custom profiling tools 2014-03-09 15:44:40 -04:00
3 changed files with 29 additions and 3 deletions

View File

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

View File

@ -19,8 +19,27 @@
(provide run-ground-vm)
(require/typed profile
[profile-thunk ((-> Void) #:custom-key (Option (Pairof
(Continuation-Mark-Keyof Any)
(-> (Listof Any) (Listof Any))))
-> Void)])
(: run-ground-vm : process-spec -> Void)
(define (run-ground-vm boot)
(profile-thunk
(lambda ()
(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)
'(ground)
(cons vs (loop (cdr vs)))))))))
#:custom-key #f))
(: run-ground-vm* : process-spec -> Void)
(define (run-ground-vm* boot)
(let loop ((state (make-vm boot)))
(match (run-vm state)
[(transition state actions)

View File

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