basis/tools/profiler/sampling/sampling.factor

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