Compare commits
2 Commits
Author | SHA1 | Date |
---|---|---|
Vincent St-Amour | c3574966bc | |
Vincent St-Amour | 70b06aa0b0 |
14
ground.rkt
14
ground.rkt
|
@ -19,8 +19,22 @@
|
||||||
|
|
||||||
(provide run-ground-vm)
|
(provide run-ground-vm)
|
||||||
|
|
||||||
|
(require/typed "profiling.rkt"
|
||||||
|
[#:opaque Feature feature?]
|
||||||
|
[marketplace-feature Feature])
|
||||||
|
(require/typed feature-profile
|
||||||
|
[feature-profile-thunk ((-> Void) [#:extra-features (Listof Feature)] -> Void)])
|
||||||
|
|
||||||
(: run-ground-vm : process-spec -> Void)
|
(: run-ground-vm : process-spec -> Void)
|
||||||
(define (run-ground-vm boot)
|
(define (run-ground-vm boot)
|
||||||
|
(feature-profile-thunk
|
||||||
|
#:extra-features (list marketplace-feature)
|
||||||
|
(lambda ()
|
||||||
|
(with-handlers ([exn:break? void])
|
||||||
|
(run-ground-vm* boot)))))
|
||||||
|
|
||||||
|
(: run-ground-vm* : process-spec -> Void)
|
||||||
|
(define (run-ground-vm* boot)
|
||||||
(let loop ((state (make-vm boot)))
|
(let loop ((state (make-vm boot)))
|
||||||
(match (run-vm state)
|
(match (run-vm state)
|
||||||
[(transition state actions)
|
[(transition state actions)
|
||||||
|
|
|
@ -12,7 +12,10 @@
|
||||||
action-tree->quasiqueue
|
action-tree->quasiqueue
|
||||||
quit-interruptk
|
quit-interruptk
|
||||||
run-ready
|
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)
|
(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))
|
(send-to-user* (process-debug-name p) (process-pid p) (e) failure-result enclosed-expr))
|
||||||
|
@ -26,7 +29,9 @@
|
||||||
debug-name pid e))
|
debug-name pid e))
|
||||||
failure-result)])
|
failure-result)])
|
||||||
(marketplace-log 'debug "Entering process ~v(~v)" debug-name pid)
|
(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)
|
(marketplace-log 'debug "Leaving process ~v(~v)" debug-name pid)
|
||||||
result))
|
result))
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,30 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(require feature-profile/plug-in-lib
|
||||||
|
(only-in profile/render-text render)
|
||||||
|
(only-in profile/analyzer analyze-samples)
|
||||||
|
"process.rkt")
|
||||||
|
|
||||||
|
(provide marketplace-feature feature?)
|
||||||
|
|
||||||
|
(define marketplace-feature
|
||||||
|
(feature "Marketplace" marketplace-continuation-mark-key values ; no grouper. no basic analysis.
|
||||||
|
(lambda (f-p)
|
||||||
|
(define intern (make-interner))
|
||||||
|
;; add thread id and timestamp back on each core sample
|
||||||
|
(define post-processed
|
||||||
|
(for/list ([c-s (feature-report-core-samples f-p)]
|
||||||
|
[p-s (cdr (feature-report-raw-samples f-p))])
|
||||||
|
;; process identifiers are the full ancestry of a process,
|
||||||
|
;; starting at the ground VM. computed from core samples.
|
||||||
|
(define processed
|
||||||
|
(let loop ([vs (filter values c-s)]) ; remove absent marks
|
||||||
|
(if (null? vs) '(ground) (cons vs (loop (cdr vs))))))
|
||||||
|
(list* (car p-s) (cadr p-s) ; thread id + timestamp
|
||||||
|
(for/list ([v processed])
|
||||||
|
;; analyzer expects (id . srcloc) pairs
|
||||||
|
;; car may not actually be an id, but that's ok
|
||||||
|
(intern (cons v #f))))))
|
||||||
|
;; call the edge profiler
|
||||||
|
(newline) (newline) (displayln "Marketplace Processes\n")
|
||||||
|
(render (analyze-samples (cons (feature-report-total-time f-p) post-processed))))))
|
Loading…
Reference in New Issue