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