basis/tools/memory/memory.factor

   1 ! Copyright (C) 2005, 2011 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs binary-search classes
   4 classes.struct combinators combinators.smart continuations fry
   5 generalizations generic grouping io io.styles kernel make math
   6 math.order math.parser math.statistics memory layouts namespaces
   7 parser prettyprint sequences sequences.generalizations sorting
   8 splitting strings system vm words hints hashtables ;
   9 IN: tools.memory
  10
  11 <PRIVATE
  12
  13 : commas ( n -- str )
  14     dup 0 < [ neg commas "-" prepend ] [
  15         number>string
  16         reverse 3 group "," join reverse
  17     ] if ;
  18
  19 : kilobytes ( n -- str )
  20     1024 /i commas " KB" append ;
  21
  22 : nanos>string ( n -- str )
  23     1000 /i commas " µs" append ;
  24
  25 : copying-room. ( copying-sizes -- )
  26     {
  27         { "Size:" [ size>> kilobytes ] }
  28         { "Occupied:" [ occupied>> kilobytes ] }
  29         { "Free:" [ free>> kilobytes ] }
  30     } object-table. ;
  31
  32 : nursery-room. ( data-room -- )
  33     "- Nursery space" print nursery>> copying-room. ;
  34
  35 : aging-room. ( data-room -- )
  36     "- Aging space" print aging>> copying-room. ;
  37
  38 : mark-sweep-table. ( mark-sweep-sizes -- )
  39     {
  40         { "Size:" [ size>> kilobytes ] }
  41         { "Occupied:" [ occupied>> kilobytes ] }
  42         { "Total free:" [ total-free>> kilobytes ] }
  43         { "Contiguous free:" [ contiguous-free>> kilobytes ] }
  44         { "Free block count:" [ free-block-count>> number>string ] }
  45     } object-table. ;
  46
  47 : tenured-room. ( data-room -- )
  48     "- Tenured space" print tenured>> mark-sweep-table. ;
  49
  50 : misc-room. ( data-room -- )
  51     "- Miscellaneous buffers" print
  52     {
  53         { "Card array:" [ cards>> kilobytes ] }
  54         { "Deck array:" [ decks>> kilobytes ] }
  55         { "Mark stack:" [ mark-stack>> kilobytes ] }
  56     } object-table. ;
  57
  58 PRIVATE>
  59
  60 : data-room ( -- data-heap-room )
  61     (data-room) data-heap-room memory>struct ;
  62
  63 : data-room. ( -- )
  64     "== Data heap ==" print nl
  65     data-room {
  66         [ nursery-room. nl ]
  67         [ aging-room. nl ]
  68         [ tenured-room. nl ]
  69         [ misc-room. ]
  70     } cleave ;
  71
  72 <PRIVATE
  73
  74 : heap-stat-step ( obj counts sizes -- )
  75     [ [ class-of ] dip inc-at ]
  76     [ [ [ size ] [ class-of ] bi ] dip at+ ] bi-curry* bi ;
  77
  78 PRIVATE>
  79
  80 : heap-stats ( -- counts sizes )
  81     [ ] instances H{ } clone H{ } clone
  82     [ '[ _ _ heap-stat-step ] each ] 2keep ;
  83
  84 : heap-stats. ( -- )
  85     heap-stats dup keys natural-sort standard-table-style [
  86         [ { "Class" "Bytes" "Instances" } [ write-cell ] each ] with-row
  87         [
  88             [
  89                 dup pprint-cell
  90                 dup pick at pprint-cell
  91                 pick at pprint-cell
  92             ] with-row
  93         ] each 2drop
  94     ] tabular-output nl ;
  95
  96 : collect-gc-events ( quot -- gc-events )
  97     enable-gc-events
  98     [ ] [ disable-gc-events drop ] cleanup
  99     disable-gc-events [ gc-event memory>struct ] map ; inline
 100
 101 <PRIVATE
 102
 103 : gc-op-string ( op -- string )
 104     {
 105         { collect-nursery-op      [ "Copying from nursery" ] }
 106         { collect-aging-op        [ "Copying from aging"   ] }
 107         { collect-to-tenured-op   [ "Copying to tenured"   ] }
 108         { collect-full-op         [ "Mark and sweep"       ] }
 109         { collect-compact-op      [ "Mark and compact"     ] }
 110         { collect-growing-heap-op [ "Grow heap"            ] }
 111     } case ;
 112
 113 : (space-occupied) ( data-heap-room code-heap-room -- n )
 114     [
 115         [ [ nursery>> ] [ aging>> ] [ tenured>> ] tri [ occupied>> ] tri@ ]
 116         [ occupied>> ]
 117         bi*
 118     ] sum-outputs ;
 119
 120 : space-occupied-before ( event -- bytes )
 121     [ data-heap-before>> ] [ code-heap-before>> ] bi (space-occupied) ;
 122
 123 : space-occupied-after ( event -- bytes )
 124     [ data-heap-after>> ] [ code-heap-after>> ] bi (space-occupied) ;
 125
 126 : space-reclaimed ( event -- bytes )
 127     [ space-occupied-before ] [ space-occupied-after ] bi - ;
 128
 129 TUPLE: gc-stats collections times ;
 130
 131 : <gc-stats> ( -- stats )
 132     gc-stats new
 133         0 >>collections
 134         V{ } clone >>times ; inline
 135
 136 : compute-gc-stats ( events -- stats )
 137     V{ } clone [
 138         '[
 139             dup op>> _ [ drop <gc-stats> ] cache
 140             [ 1 + ] change-collections
 141             [ total-time>> ] dip times>> push
 142         ] each
 143     ] keep sort-keys ;
 144
 145 : gc-stats-table-row ( pair -- row )
 146     [
 147         [ first gc-op-string ] [
 148             second
 149             [ collections>> ]
 150             [
 151                 times>> {
 152                     [ sum nanos>string ]
 153                     [ mean >integer nanos>string ]
 154                     [ median >integer nanos>string ]
 155                     [ infimum nanos>string ]
 156                     [ supremum nanos>string ]
 157                 } cleave
 158             ] bi
 159         ] bi
 160     ] output>array ;
 161
 162 : gc-stats-table ( stats -- table )
 163     [ gc-stats-table-row ] map
 164     { "" "Number" "Total" "Mean" "Median" "Min" "Max" } prefix ;
 165
 166 PRIVATE>
 167
 168 SYMBOL: gc-events
 169
 170 : gc-event. ( event -- )
 171     {
 172         { "Event type:" [ op>> gc-op-string ] }
 173         { "Total time:" [ total-time>> nanos>string ] }
 174         { "Space reclaimed:" [ space-reclaimed kilobytes ] }
 175     } object-table. ;
 176
 177 : gc-events. ( -- )
 178     gc-events get [ gc-event. nl ] each ;
 179
 180 : gc-stats. ( -- )
 181     gc-events get compute-gc-stats gc-stats-table simple-table. ;
 182
 183 : gc-summary. ( -- )
 184     gc-events get {
 185         { "Collections:" [ length commas ] }
 186         { "Cards scanned:" [ [ cards-scanned>> ] map-sum commas ] }
 187         { "Decks scanned:" [ [ decks-scanned>> ] map-sum commas ] }
 188         { "Code blocks scanned:" [ [ code-blocks-scanned>> ] map-sum commas ] }
 189         { "Total time:" [ [ total-time>> ] map-sum nanos>string ] }
 190         { "Card scan time:" [ [ card-scan-time>> ] map-sum nanos>string ] }
 191         { "Code block scan time:" [ [ code-scan-time>> ] map-sum nanos>string ] }
 192         { "Data heap sweep time:" [ [ data-sweep-time>> ] map-sum nanos>string ] }
 193         { "Code heap sweep time:" [ [ code-sweep-time>> ] map-sum nanos>string ] }
 194         { "Compaction time:" [ [ compaction-time>> ] map-sum nanos>string ] }
 195     } object-table. ;
 196
 197 SINGLETONS: +unoptimized+ +optimized+ +profiling+ +pic+ ;
 198
 199 TUPLE: code-block
 200 { owner read-only }
 201 { parameters read-only }
 202 { relocation read-only }
 203 { type read-only }
 204 { size read-only }
 205 { entry-point read-only } ;
 206
 207 TUPLE: code-blocks { blocks groups } { cache hashtable } ;
 208
 209 <PRIVATE
 210
 211 : code-block-type ( n -- type )
 212     { +unoptimized+ +optimized+ +profiling+ +pic+ } nth ;
 213
 214 : <code-block> ( seq -- code-block )
 215     6 firstn-unsafe {
 216         [ ]
 217         [ ]
 218         [ ]
 219         [ code-block-type ]
 220         [ ]
 221         [ tag-bits get shift ]
 222     } spread code-block boa ; inline
 223
 224 : <code-blocks> ( seq -- code-blocks )
 225     6 <groups> H{ } clone \ code-blocks boa ;
 226
 227 SYMBOL: code-heap-start
 228 SYMBOL: code-heap-end
 229
 230 : in-code-heap? ( address -- ? )
 231     code-heap-start get code-heap-end get between? ;
 232
 233 : (lookup-return-address) ( addr seq -- code-block )
 234     [ entry-point>> <=> ] with search nip ;
 235
 236 HINTS: (lookup-return-address) code-blocks ;
 237
 238 PRIVATE>
 239
 240 M: code-blocks length blocks>> length ; inline
 241
 242 FROM: sequences.private => nth-unsafe ;
 243
 244 M: code-blocks nth-unsafe
 245     [ cache>> ] [ blocks>> ] bi
 246     '[ _ nth-unsafe <code-block> ] cache ; inline
 247
 248 INSTANCE: code-blocks immutable-sequence
 249
 250 : get-code-blocks ( -- blocks )
 251     (code-blocks) <code-blocks> ;
 252
 253 : with-code-blocks ( quot -- )
 254     [
 255         get-code-blocks
 256         [ \ code-blocks set ]
 257         [ first entry-point>> code-heap-start set ]
 258         [ last [ entry-point>> ] [ size>> ] bi + code-heap-end set ] tri
 259         call
 260     ] with-scope ; inline
 261
 262 : lookup-return-address ( addr -- code-block )
 263     dup in-code-heap?
 264     [ \ code-blocks get (lookup-return-address) ] [ drop f ] if ;
 265
 266 <PRIVATE
 267
 268 : code-block-stats ( code-blocks -- counts sizes )
 269     H{ } clone H{ } clone
 270     [ '[ [ size>> ] [ type>> ] bi [ nip _ inc-at ] [ _ at+ ] 2bi ] each ]
 271     2keep ;
 272
 273 : blocks ( n -- str ) number>string " blocks" append ;
 274
 275 : code-block-table-row ( string type counts sizes -- triple )
 276     [ at 0 or blocks ] [ at 0 or kilobytes ] bi-curry* bi 3array ;
 277
 278 : code-block-table. ( counts sizes -- )
 279     [
 280         {
 281             { "Optimized code:" +optimized+ }
 282             { "Unoptimized code:" +unoptimized+ }
 283             { "Inline caches:" +pic+ }
 284             { "Profiling stubs:" +profiling+ }
 285         }
 286     ] 2dip '[ _ _ code-block-table-row ] { } assoc>map
 287     simple-table. ;
 288
 289 PRIVATE>
 290
 291 : code-room ( -- mark-sweep-sizes )
 292     (code-room) mark-sweep-sizes memory>struct ;
 293
 294 : callback-room ( -- mark-sweep-sizes )
 295     (callback-room) mark-sweep-sizes memory>struct ;
 296
 297 : code-room. ( -- )
 298     "== Code heap ==" print nl
 299     code-room mark-sweep-table. nl
 300     get-code-blocks code-block-stats code-block-table. ;
 301
 302 : callback-room. ( -- )
 303     "== Callback heap ==" print nl
 304     callback-room mark-sweep-table. ;
 305
 306 : room. ( -- )
 307     data-room. nl code-room. nl callback-room. ;