tools.profiler.sampling: "top-down" and "profile."

basis/tools/profiler/sampling/sampling.factor

@@ -1,6 +1,9 @@
 ! (c)2011 Joe Groff bsd license
-USING: assocs calendar continuations kernel math.statistics
-math namespaces sequences tools.profiler.sampling.private ;
+USING: accessors assocs calendar continuations fry io
+kernel kernel.private locals math math.statistics
+math.vectors namespaces prettyprint sequences sorting
+tools.profiler.sampling.private ;
+FROM: sequences => change-nth ;
 IN: tools.profiler.sampling
 
 SYMBOL: raw-profile-data
@@ -8,6 +11,9 @@ SYMBOL: samples-per-second
 
 CONSTANT: default-samples-per-second 1000
 
+CONSTANT: ignore-words
+    { signal-handler leaf-signal-handler profiling }
+
 : get-raw-profile-data ( -- data )
     raw-profile-data get-global [ "No profile data" throw ] unless* ;
 
@@ -49,5 +55,57 @@ CONSTANT: default-samples-per-second 1000
 : foreign-thread-time ( -- n )
     get-raw-profile-data (foreign-thread-time) ;
 
+: collect-contexts ( samples -- by-top )
+    [ sample-context ] collect-by ;
+
 : time-per-context ( -- n )
-    get-raw-profile-data [ sample-context ] collect-by [ (total-time) ] assoc-map ;
+    get-raw-profile-data collect-contexts [ (total-time) ] assoc-map ;
+
+: unclip-callstack ( sample -- sample' callstack-top )
+    clone 5 over [ unclip swap ] change-nth ;
+
+TUPLE: profile-node
+    total-time gc-time foreign-time foreign-thread-time children ;
+
+:: (collect-subtrees) ( samples child-quot -- node )
+    samples { 0 0 0 0 } [ 4 head-slice v+ ] reduce [ samples>time ] map! :> times
+    samples [ sample-callstack [ ignore-words member? not ] filter empty? not ] filter
+    [ f ] [ child-quot call ] if-empty :> subtree
+    times first4 subtree profile-node boa ; inline
+
+: collect-tops ( samples -- node )
+    [ unclip-callstack ] collect-pairs
+    [ [ collect-tops ] (collect-subtrees) ] assoc-map ;
+
+: trim-tree ( assoc -- assoc' )
+    dup assoc-size 1 = [
+        dup values first children>> dup assoc-size 1 =
+        [ nip trim-tree ] [ drop ] if
+    ] when ;
+
+: (top-down) ( samples -- tree )
+    collect-contexts [ collect-tops trim-tree ] assoc-map ;
+
+: top-down ( -- tree )
+    get-raw-profile-data (top-down) ;
+
+: depth. ( depth -- )
+    [ "  " write ] times ;
+
+: by-total-time ( nodes -- nodes' )
+    >alist [ second total-time>> ] inv-sort-with ;
+
+: duration. ( duration -- )
+    duration>seconds >float pprint " " write \ seconds pprint ;
+
+DEFER: (profile.)
+
+:: (profile-node.) ( word node depth -- )
+    depth depth. node total-time>> duration. ": " write word pprint nl
+    node children>> depth 1 + (profile.) ;
+
+: (profile.) ( nodes depth -- )
+    [ by-total-time ] dip '[ _ (profile-node.) ] assoc-each ;
+
+: profile. ( tree -- )
+    [ [ "Context: " write pprint nl ] [ 1 (profile.) ] bi* ] assoc-each ;