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