From f645c82b8a7be485dcf8c8d577f55dc4f888c4f0 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 1 Nov 2011 17:52:35 -0700
Subject: [PATCH] tools.profiler.sampling: add detail to profile.
---
basis/tools/profiler/sampling/sampling.factor | 64 +++++++++++++------
1 file changed, 44 insertions(+), 20 deletions(-)
diff --git a/basis/tools/profiler/sampling/sampling.factor b/basis/tools/profiler/sampling/sampling.factor
index e53398ac5d..cfab4f06d2 100644
--- a/basis/tools/profiler/sampling/sampling.factor
+++ b/basis/tools/profiler/sampling/sampling.factor
@@ -1,7 +1,8 @@
! (c)2011 Joe Groff bsd license
-USING: accessors assocs calendar continuations fry io
-kernel kernel.private locals math math.statistics
-math.vectors namespaces prettyprint sequences sorting
+USING: accessors assocs calendar combinators
+combinators.short-circuit continuations fry io kernel
+kernel.private locals math math.statistics math.vectors memory
+namespaces prettyprint sequences sorting
tools.profiler.sampling.private ;
FROM: sequences => change-nth ;
IN: tools.profiler.sampling
@@ -12,7 +13,7 @@ SYMBOL: samples-per-second
CONSTANT: default-samples-per-second 1000
CONSTANT: ignore-words
- { signal-handler leaf-signal-handler profiling }
+ { signal-handler leaf-signal-handler profiling minor-gc }
: get-raw-profile-data ( -- data )
raw-profile-data get-global [ "No profile data" throw ] unless* ;
@@ -67,24 +68,39 @@ CONSTANT: ignore-words
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
+: <profile-node> ( times children -- node )
+ [ first4 ] dip profile-node boa ;
+
+: leaf-callstack? ( callstack -- ? )
+ [ 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 )
- [ unclip-callstack ] collect-pairs
- [ [ collect-tops ] (collect-subtrees) ] assoc-map ;
+ [ unclip-callstack ] collect-pairs [
+ [ sum-times ]
+ [ [ collect-tops ] (collect-subtrees) ] bi <profile-node>
+ ] assoc-map ;
-: trim-tree ( assoc -- assoc' )
- dup assoc-size 1 = [
- dup values first children>> dup assoc-size 1 =
- [ nip trim-tree ] [ drop ] if
- ] when ;
+: redundant-root-node? ( assoc -- ? )
+ {
+ [ children>> assoc-size 1 = ]
+ [ children>> values first children>> ]
+ [ [ 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 )
- collect-contexts [ collect-tops trim-tree ] assoc-map ;
+ collect-contexts [
+ [ sum-times ] [ collect-tops ] bi <profile-node> trim-root
+ ] assoc-map ;
: top-down ( -- tree )
get-raw-profile-data (top-down) ;
@@ -96,16 +112,24 @@ TUPLE: profile-node
>alist [ second total-time>> ] inv-sort-with ;
: duration. ( duration -- )
- duration>seconds >float pprint " " write \ seconds pprint ;
+ duration>milliseconds >integer pprint "ms" write ;
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 -- )
- depth depth. node total-time>> duration. ": " write word pprint nl
+ depth depth. node times. ": " 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 ;
+ [ 0 (profile-node.) ] assoc-each ;