basis/tools/memory/memory.factor

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