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

tools.profiler.sampling: add detail to profile.

db4
Joe Groff 2011-11-01 17:52:35 -07:00
parent d4736d4e3a
commit f645c82b8a
1 changed files with 44 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,7 +1,8 @@
! (c)2011 Joe Groff bsd license ! (c)2011 Joe Groff bsd license
USING: accessors assocs calendar continuations fry io USING: accessors assocs calendar combinators
kernel kernel.private locals math math.statistics combinators.short-circuit continuations fry io kernel
math.vectors namespaces prettyprint sequences sorting kernel.private locals math math.statistics math.vectors memory
namespaces prettyprint sequences sorting
tools.profiler.sampling.private ; tools.profiler.sampling.private ;
FROM: sequences => change-nth ; FROM: sequences => change-nth ;
IN: tools.profiler.sampling IN: tools.profiler.sampling
@ -12,7 +13,7 @@ SYMBOL: samples-per-second
CONSTANT: default-samples-per-second 1000 CONSTANT: default-samples-per-second 1000
CONSTANT: ignore-words CONSTANT: ignore-words
{ signal-handler leaf-signal-handler profiling } { signal-handler leaf-signal-handler profiling minor-gc }
: 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* ;
@ -67,24 +68,39 @@ CONSTANT: ignore-words
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 ;
:: (collect-subtrees) ( samples child-quot -- node ) : <profile-node> ( times children -- node )
samples { 0 0 0 0 } [ 4 head-slice v+ ] reduce [ samples>time ] map! :> times [ first4 ] dip profile-node boa ;
samples [ sample-callstack [ ignore-words member? not ] filter empty? not ] filter
[ f ] [ child-quot call ] if-empty :> subtree : leaf-callstack? ( callstack -- ? )
times first4 subtree profile-node boa ; inline [ ignore-words member? ] all? ;
: sum-times ( samples -- times )
{ 0 0 0 0 } [ 4 head-slice v+ ] reduce [ samples>time ] map! ;
:: (collect-subtrees) ( samples child-quot -- children )
samples [ sample-callstack leaf-callstack? not ] filter
[ f ] [ child-quot call ] if-empty ; inline
: collect-tops ( samples -- node ) : collect-tops ( samples -- node )
[ unclip-callstack ] collect-pairs [ unclip-callstack ] collect-pairs [
[ [ collect-tops ] (collect-subtrees) ] assoc-map ; [ sum-times ]
[ [ collect-tops ] (collect-subtrees) ] bi <profile-node>
] assoc-map ;
: trim-tree ( assoc -- assoc' ) : redundant-root-node? ( assoc -- ? )
dup assoc-size 1 = [ {
dup values first children>> dup assoc-size 1 = [ children>> assoc-size 1 = ]
[ nip trim-tree ] [ drop ] if [ children>> values first children>> ]
] when ; [ [ total-time>> ] [ children>> values first total-time>> ] bi = ]
} 1&& ;
: trim-root ( root -- root' )
dup redundant-root-node? [ children>> values first trim-root ] when ;
: (top-down) ( samples -- tree ) : (top-down) ( samples -- tree )
collect-contexts [ collect-tops trim-tree ] assoc-map ; collect-contexts [
[ sum-times ] [ collect-tops ] bi <profile-node> trim-root
] assoc-map ;
: top-down ( -- tree ) : top-down ( -- tree )
get-raw-profile-data (top-down) ; get-raw-profile-data (top-down) ;
@ -96,16 +112,24 @@ TUPLE: profile-node
>alist [ second total-time>> ] inv-sort-with ; >alist [ second total-time>> ] inv-sort-with ;
: duration. ( duration -- ) : duration. ( duration -- )
duration>seconds >float pprint " " write \ seconds pprint ; duration>milliseconds >integer pprint "ms" write ;
DEFER: (profile.) DEFER: (profile.)
: times. ( node -- )
{
[ total-time>> duration. " (" write ]
[ gc-time>> duration. " gc, " write ]
[ foreign-time>> duration. " foreign, " write ]
[ foreign-thread-time>> duration. " foreign threads)" write ]
} cleave ;
:: (profile-node.) ( word node depth -- ) :: (profile-node.) ( word node depth -- )
depth depth. node total-time>> duration. ": " write word pprint nl depth depth. node times. ": " write word pprint nl
node children>> depth 1 + (profile.) ; node children>> depth 1 + (profile.) ;
: (profile.) ( nodes depth -- ) : (profile.) ( nodes depth -- )
[ by-total-time ] dip '[ _ (profile-node.) ] assoc-each ; [ by-total-time ] dip '[ _ (profile-node.) ] assoc-each ;
: profile. ( tree -- ) : profile. ( tree -- )
[ [ "Context: " write pprint nl ] [ 1 (profile.) ] bi* ] assoc-each ; [ 0 (profile-node.) ] assoc-each ;