steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

tools.profiler.sampling: groom flat profile

db4
Joe Groff 2011-11-01 20:18:52 -07:00
parent be8db5aed3
commit 4330a645f4
1 changed files with 22 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
basis/tools/profiler/sampling/sampling.factor
View File

@ -2,7 +2,7 @@
USING: accessors assocs calendar combinators USING: accessors assocs calendar combinators
combinators.short-circuit continuations fry io kernel combinators.short-circuit continuations fry io kernel
kernel.private locals math math.statistics math.vectors memory kernel.private locals math math.statistics math.vectors memory
namespaces prettyprint sequences sorting namespaces prettyprint sequences sets sorting
tools.profiler.sampling.private hashtables.identity generalizations ; tools.profiler.sampling.private hashtables.identity generalizations ;
FROM: sequences => change-nth ; FROM: sequences => change-nth ;
FROM: assocs => change-at ; FROM: assocs => change-at ;
@ -16,6 +16,8 @@ CONSTANT: default-samples-per-second 1000
CONSTANT: ignore-words CONSTANT: ignore-words
{ signal-handler leaf-signal-handler profiling minor-gc } { signal-handler leaf-signal-handler profiling minor-gc }
: ignore-word? ( word -- ? ) ignore-words member? ; inline
: get-raw-profile-data ( -- data ) : get-raw-profile-data ( -- data )
raw-profile-data get-global [ "No profile data" throw ] unless* ; raw-profile-data get-global [ "No profile data" throw ] unless* ;
@ -66,17 +68,20 @@ CONSTANT: ignore-words
: unclip-callstack ( sample -- sample' callstack-top ) : unclip-callstack ( sample -- sample' callstack-top )
clone 5 over [ unclip swap ] change-nth ; clone 5 over [ unclip swap ] change-nth ;
: leaf-callstack? ( callstack -- ? )
[ ignore-word? ] all? ;
: sum-times ( samples -- times )
{ 0 0 0 0 } [ 4 head-slice v+ ] reduce ;
TUPLE: profile-node TUPLE: profile-node
total-time gc-time foreign-time foreign-thread-time children ; total-time gc-time foreign-time foreign-thread-time children ;
: <profile-node> ( times children -- node ) : <profile-node> ( times children -- node )
[ first4 [ samples>time ] 4 napply ] dip profile-node boa ; [ first4 [ samples>time ] 4 napply ] dip profile-node boa ;
: leaf-callstack? ( callstack -- ? ) : <profile-root-node> ( samples collector-quot -- node )
[ ignore-words member? ] all? ; [ sum-times ] swap bi <profile-node> ; inline
: sum-times ( samples -- times )
{ 0 0 0 0 } [ 4 head-slice v+ ] reduce ;
:: (collect-subtrees) ( samples child-quot -- children ) :: (collect-subtrees) ( samples child-quot -- children )
samples [ sample-callstack leaf-callstack? not ] filter samples [ sample-callstack leaf-callstack? not ] filter
@ -99,9 +104,8 @@ TUPLE: profile-node
dup redundant-root-node? [ children>> values first trim-root ] when ; dup redundant-root-node? [ children>> values first trim-root ] when ;
: (top-down) ( samples -- tree ) : (top-down) ( samples -- tree )
collect-threads [ collect-threads
[ sum-times ] [ collect-tops ] bi <profile-node> trim-root [ [ collect-tops ] <profile-root-node> trim-root ] assoc-map ;
] assoc-map ;
: top-down ( -- tree ) : top-down ( -- tree )
get-raw-profile-data (top-down) ; get-raw-profile-data (top-down) ;
@ -109,16 +113,21 @@ TUPLE: profile-node
:: collect-flat ( samples -- flat ) :: collect-flat ( samples -- flat )
IH{ } clone :> per-word-samples IH{ } clone :> per-word-samples
samples [| sample | samples [| sample |
sample sample-callstack unique keys [ sample sample-callstack unique keys [ ignore-word? not ] filter [
per-word-samples [ { 0 0 0 0 } or sample 4 head-slice v+ ] change-at per-word-samples [ { 0 0 0 0 } or sample 4 head-slice v+ ] change-at
] each ] each
] each ] each
per-word-samples [ f <profile-node> ] assoc-map ; per-word-samples [ f <profile-node> ] assoc-map ;
: redundant-flat-node? ( child-node root-node -- ? )
[ total-time>> ] bi@ = ;
: trim-flat ( root-node -- root-node' )
dup '[ [ nip _ redundant-flat-node? not ] assoc-filter ] change-children ;
: (flat) ( samples -- flat ) : (flat) ( samples -- flat )
collect-threads [ collect-threads
[ sum-times ] [ collect-flat ] bi <profile-node> [ [ collect-flat ] <profile-root-node> trim-flat ] assoc-map ;
] assoc-map ;
: flat ( -- tree ) : flat ( -- tree )
get-raw-profile-data (flat) ; get-raw-profile-data (flat) ;