basis/tools/memory/memory.factor

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