basis/tools/profiler/sampling/sampling.factor

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