basis/tools/memory/memory.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel sequences vectors arrays generic assocs io math
   4 namespaces parser prettyprint strings io.styles vectors words
   5 system sorting splitting grouping math.parser classes memory
   6 combinators ;
   7 IN: tools.memory
   8
   9 <PRIVATE
  10
  11 : write-size ( n -- )
  12     number>string
  13     dup length 4 > [ 3 cut* "," swap 3append ] when
  14     " KB" append write-cell ;
  15
  16 : write-total/used/free ( free total str -- )
  17     [
  18         write-cell
  19         dup write-size
  20         over - write-size
  21         write-size
  22     ] with-row ;
  23
  24 : write-total ( n str -- )
  25     [
  26         write-cell
  27         write-size
  28         [ ] with-cell
  29         [ ] with-cell
  30     ] with-row ;
  31
  32 : write-headings ( seq -- )
  33     [ [ write-cell ] each ] with-row ;
  34
  35 : (data-room.) ( -- )
  36     data-room 2 <groups> [
  37         [ first2 ] [ number>string "Generation " prepend ] bi*
  38         write-total/used/free
  39     ] each-index
  40     "Decks" write-total
  41     "Cards" write-total ;
  42
  43 : write-labelled-size ( n string -- )
  44     [ write-cell write-size ] with-row ;
  45
  46 : (code-room.) ( -- )
  47     code-room {
  48         [ "Size:" write-labelled-size ]
  49         [ "Used:" write-labelled-size ]
  50         [ "Total free space:" write-labelled-size ]
  51         [ "Largest free block:" write-labelled-size ]
  52     } spread ;
  53
  54 : heap-stat-step ( counts sizes obj -- )
  55     [ dup size swap class rot at+ ] keep
  56     1 swap class rot at+ ;
  57
  58 PRIVATE>
  59
  60 : room. ( -- )
  61     "==== DATA HEAP" print
  62     standard-table-style [
  63         { "" "Total" "Used" "Free" } write-headings
  64         (data-room.)
  65     ] tabular-output
  66     nl
  67     "==== CODE HEAP" print
  68     standard-table-style [
  69         (code-room.)
  70     ] tabular-output ;
  71
  72 : heap-stats ( -- counts sizes )
  73     H{ } clone H{ } clone
  74     [ >r 2dup r> heap-stat-step ] each-object ;
  75
  76 : heap-stats. ( -- )
  77     heap-stats dup keys natural-sort standard-table-style [
  78         { "Class" "Bytes" "Instances" } write-headings
  79         [
  80             [
  81                 dup pprint-cell
  82                 dup pick at pprint-cell
  83                 pick at pprint-cell
  84             ] with-row
  85         ] each 2drop
  86     ] tabular-output ;