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 fry ;
   7 IN: tools.memory
   8
   9 <PRIVATE
  10
  11 : write-size ( n -- )
  12     number>string
  13     dup length 4 > [ 3 cut* "," glue ] 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 ( obj counts sizes -- )
  55     [ over ] dip
  56     [ [ class ] dip inc-at ]
  57     [ [ [ size ] [ class ] bi ] dip at+ ] 2bi* ;
  58
  59 PRIVATE>
  60
  61 : room. ( -- )
  62     "==== DATA HEAP" print
  63     standard-table-style [
  64         { "" "Total" "Used" "Free" } write-headings
  65         (data-room.)
  66     ] tabular-output
  67     nl
  68     "==== CODE HEAP" print
  69     standard-table-style [
  70         (code-room.)
  71     ] tabular-output ;
  72
  73 : heap-stats ( -- counts sizes )
  74     H{ } clone H{ } clone
  75     2dup '[ _ _ heap-stat-step ] each-object ;
  76
  77 : heap-stats. ( -- )
  78     heap-stats dup keys natural-sort standard-table-style [
  79         { "Class" "Bytes" "Instances" } write-headings
  80         [
  81             [
  82                 dup pprint-cell
  83                 dup pick at pprint-cell
  84                 pick at pprint-cell
  85             ] with-row
  86         ] each 2drop
  87     ] tabular-output ;