From d4736d4e3ae9909d635ec6ba5f396ed97495578e Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 1 Nov 2011 13:10:58 -0700
Subject: [PATCH] tools.profiler.sampling: "top-down" and "profile."
---
basis/tools/profiler/sampling/sampling.factor | 64 ++++++++++++++++++-
1 file changed, 61 insertions(+), 3 deletions(-)
diff --git a/basis/tools/profiler/sampling/sampling.factor b/basis/tools/profiler/sampling/sampling.factor
index 021284b4a1..e53398ac5d 100644
--- a/basis/tools/profiler/sampling/sampling.factor
+++ b/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 ;