basis/tools/profiler/sampling/sampling.factor

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