basis/tools/profiler/sampling/sampling.factor

   1 ! (c)2011 Joe Groff bsd license
   2 USING: accessors assocs combinators combinators.short-circuit
   3 continuations formatting fry generalizations hashtables.identity
   4 io kernel kernel.private layouts locals math math.parser
   5 math.statistics math.vectors memory namespaces prettyprint
   6 sequences sequences.generalizations sets sorting ;
   7 FROM: sequences => change-nth ;
   8 FROM: assocs => change-at ;
   9 IN: tools.profiler.sampling
  10
  11 SYMBOL: samples-per-second
  12
  13 samples-per-second [ 1,000 ] initialize
  14
  15 <PRIVATE
  16 SYMBOL: raw-profile-data
  17 CONSTANT: ignore-words
  18     { signal-handler leaf-signal-handler profiling minor-gc }
  19
  20 : ignore-word? ( word -- ? ) ignore-words member? ; inline
  21 PRIVATE>
  22
  23 : most-recent-profile-data ( -- profile-data )
  24     raw-profile-data get-global [ "No profile data" throw ] unless* ;
  25
  26 : profile ( quot -- )
  27     samples-per-second get-global profiling
  28     [ 0 profiling (get-samples) raw-profile-data set-global ]
  29     [ ] cleanup ; inline
  30
  31 : total-sample-count ( sample -- count ) 0 swap nth ;
  32 : gc-sample-count ( sample -- count ) 1 swap nth ;
  33 : jit-sample-count ( sample -- count ) 2 swap nth ;
  34 : foreign-sample-count ( sample -- count ) 3 swap nth ;
  35 : foreign-thread-sample-count ( sample -- count ) 4 swap nth ;
  36 : sample-counts-slice ( sample -- counts ) 5 head-slice ;
  37
  38 : sample-thread ( sample -- thread ) 5 swap nth ;
  39 : sample-callstack ( sample -- array ) 6 swap nth ;
  40 : unclip-callstack ( sample -- sample' callstack-top )
  41     clone 6 over [ unclip swap ] change-nth ;
  42
  43 : samples>time ( samples -- seconds )
  44     samples-per-second get-global / ;
  45
  46 : total-time* ( profile-data -- n )
  47     [ total-sample-count ] map-sum samples>time ;
  48
  49 : gc-time* ( profile-data -- n )
  50     [ gc-sample-count ] map-sum samples>time ;
  51
  52 : foreign-time* ( profile-data -- n )
  53     [ foreign-sample-count ] map-sum samples>time ;
  54
  55 : foreign-thread-time* ( profile-data -- n )
  56     [ foreign-thread-sample-count ] map-sum samples>time ;
  57
  58 : total-time ( -- n )
  59     most-recent-profile-data total-time* ;
  60
  61 : gc-time ( -- n )
  62     most-recent-profile-data gc-time* ;
  63
  64 : foreign-time ( -- n )
  65     most-recent-profile-data foreign-time* ;
  66
  67 : foreign-thread-time ( -- n )
  68     most-recent-profile-data foreign-thread-time* ;
  69
  70 TUPLE: profile-node
  71     total-time gc-time jit-time foreign-time foreign-thread-time children
  72     depth ;
  73
  74 <PRIVATE
  75
  76 : collect-threads ( samples -- by-thread )
  77     [ sample-thread ] collect-by ;
  78
  79 : time-per-thread ( -- n )
  80     most-recent-profile-data collect-threads [ total-time* ] assoc-map ;
  81
  82 : leaf-callstack? ( callstack -- ? )
  83     [ ignore-word? ] all? ;
  84
  85 CONSTANT: zero-counts { 0 0 0 0 0 }
  86
  87 : sum-counts ( samples -- times )
  88     zero-counts [ sample-counts-slice v+ ] reduce ;
  89
  90 : <profile-node> ( times children depth -- node )
  91     [ 5 firstn [ samples>time ] 5 napply ] 2dip profile-node boa ;
  92
  93 : <profile-root-node> ( samples collector-quot -- node )
  94     [ sum-counts ] swap bi 0 <profile-node> ; inline
  95
  96 :: (collect-subtrees) ( samples max-depth depth child-quot: ( samples -- child ) -- children )
  97     max-depth depth > [
  98         samples [ sample-callstack leaf-callstack? not ] filter
  99         [ f ] [ child-quot call ] if-empty
 100     ] [ f ] if ; inline
 101
 102 :: collect-tops ( samples max-depth depth -- node )
 103     samples H{ } clone [
 104         '[ unclip-callstack _ push-at ] each
 105     ] keep [
 106         [ sum-counts ]
 107         [ max-depth depth [ max-depth depth 1 + collect-tops ] (collect-subtrees) ] bi
 108         depth <profile-node>
 109     ] assoc-map ;
 110
 111 : redundant-root-node? ( assoc -- ? )
 112     {
 113         [ children>> assoc-size 1 = ]
 114         [ children>> values first children>> ]
 115         [ [ total-time>> ] [ children>> values first total-time>> ] bi = ]
 116     } 1&& ;
 117
 118 : trim-root ( root -- root' )
 119     dup redundant-root-node? [ children>> values first trim-root ] when ;
 120
 121 :: (top-down) ( max-depth profile-data depth -- tree )
 122     profile-data collect-threads
 123     [ [ max-depth depth collect-tops ] <profile-root-node> trim-root ] assoc-map ;
 124
 125 PRIVATE>
 126
 127 : top-down-max-depth* ( max-depth profile-data -- tree )
 128     0 (top-down) ;
 129
 130 : top-down-max-depth ( max-depth -- tree )
 131     most-recent-profile-data top-down-max-depth* ;
 132
 133 : top-down* ( profile-data -- tree )
 134     [ most-positive-fixnum ] dip top-down-max-depth* ;
 135
 136 : top-down ( -- tree )
 137     most-positive-fixnum top-down-max-depth ;
 138
 139 <PRIVATE
 140
 141 :: counts+at ( key assoc sample -- )
 142     key assoc [ zero-counts or sample sample-counts-slice v+ ] change-at ;
 143
 144 :: collect-flat ( samples -- flat )
 145     IH{ } clone :> per-word-samples
 146     samples [| sample |
 147         sample sample-callstack members [ ignore-word? not ] filter [
 148             per-word-samples sample counts+at
 149         ] each
 150     ] each
 151     per-word-samples [ f 0 <profile-node> ] assoc-map ;
 152
 153 : redundant-flat-node? ( child-node root-node -- ? )
 154     [ total-time>> ] same? ;
 155
 156 : trim-flat ( root-node -- root-node' )
 157     dup '[ [ nip _ redundant-flat-node? not ] assoc-filter ] change-children ;
 158
 159 PRIVATE>
 160
 161 : flat* ( profile-data -- flat )
 162     collect-threads
 163     [ [ collect-flat ] <profile-root-node> trim-flat ] assoc-map ;
 164
 165 : flat ( -- flat )
 166     most-recent-profile-data flat* ;
 167
 168 <PRIVATE
 169
 170 : nth-or-last ( n seq -- elt )
 171     [ drop f ] [
 172         2dup bounds-check? [ nth ] [ nip last ] if
 173     ] if-empty ;
 174
 175 :: collect-cross-section ( samples depth -- cross-section )
 176     IH{ } clone :> per-word-samples
 177     samples [| sample |
 178         depth sample sample-callstack [ ignore-word? ] trim-tail nth-or-last :> word
 179         word [
 180             word per-word-samples sample counts+at
 181         ] when
 182     ] each
 183     per-word-samples [ f depth <profile-node> ] assoc-map ;
 184
 185 PRIVATE>
 186
 187 :: cross-section* ( depth profile-data -- tree )
 188     profile-data collect-threads
 189     [ [ depth collect-cross-section ] <profile-root-node> ] assoc-map ;
 190
 191 : cross-section ( depth -- tree )
 192     most-recent-profile-data cross-section* ;
 193
 194 <PRIVATE
 195
 196 : depth. ( depth -- )
 197     [ "  " write ] times ;
 198
 199 : by-total-time ( nodes -- nodes' )
 200     >alist [ second total-time>> ] inv-sort-with ;
 201
 202 : duration. ( duration -- )
 203     1000 * "%9.1f" printf ;
 204
 205 : percentage. ( num denom -- )
 206     [ 100 * ] dip /f "%6.2f" printf ;
 207
 208 DEFER: (profile.)
 209
 210 :: times. ( node -- )
 211     node {
 212         [ depth>> number>string 4 CHAR: \s pad-head write bl ]
 213         [ total-time>> duration. bl ]
 214         [ [ gc-time>> ] [ total-time>> ] bi percentage. bl ]
 215         [ [ jit-time>> ] [ total-time>> ] bi percentage. bl ]
 216         [ [ foreign-time>> ] [ total-time>> ] bi percentage. bl ]
 217         [ [ foreign-thread-time>> ] [ total-time>> ] bi percentage. bl ]
 218     } cleave ;
 219
 220 :: (profile-node.) ( word node depth -- )
 221     node times.
 222     depth depth.
 223     word pprint-short nl
 224     node children>> depth 1 + (profile.) ;
 225
 226 : (profile.) ( nodes depth -- )
 227     [ by-total-time ] dip '[ _ (profile-node.) ] assoc-each ;
 228
 229 : profile-heading. ( -- )
 230     "depth   time ms  GC %  JIT %  FFI %   FT %" print ;
 231    ! NNNN XXXXXXX.X XXXX.X XXXX.X XXXX.X XXXX.X | | foo
 232
 233 PRIVATE>
 234
 235 : profile. ( tree -- )
 236     profile-heading.
 237     [ 0 (profile-node.) ] assoc-each ;