Add feature-specific profiling support.

This commit is contained in:
Vincent St-Amour 2014-05-01 14:34:05 -04:00
parent 70b06aa0b0
commit c3574966bc
2 changed files with 44 additions and 0 deletions

View File

@ -19,8 +19,22 @@
(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)
(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)))
(match (run-vm state)
[(transition state actions)

30
profiling.rkt Normal file
View File

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