Improve memory tooL

db4
Slava Pestov 2008-04-07 21:04:51 -05:00
parent 37d6dc70e8
commit a48120c80b
2 changed files with 44 additions and 18 deletions

View File

@ -1,4 +1,8 @@
USING: tools.test tools.memory ;
IN: tools.memory.tests
\ room. must-infer
[ ] [ room. ] unit-test
\ heap-stats. must-infer
[ ] [ heap-stats. ] unit-test

View File

@ -1,22 +1,29 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences vectors arrays generic assocs io math
namespaces parser prettyprint strings io.styles vectors words
system sorting splitting math.parser classes memory ;
system sorting splitting math.parser classes memory combinators ;
IN: tools.memory
<PRIVATE
: write-size ( n -- )
number>string
dup length 4 > [ 3 cut* "," swap 3append ] when
" KB" append write-cell ;
: write-total/used/free ( free total str -- )
[
write-cell
dup number>string write-cell
over - number>string write-cell
number>string write-cell
dup write-size
over - write-size
write-size
] with-row ;
: write-total ( n str -- )
[
write-cell
number>string write-cell
write-size
[ ] with-cell
[ ] with-cell
] with-row ;
@ -25,26 +32,41 @@ IN: tools.memory
[ [ write-cell ] each ] with-row ;
: (data-room.) ( -- )
data-room 2 <groups> 0 [
"Generation " pick number>string append
>r first2 r> write-total/used/free 1+
] reduce drop
data-room 2 <groups> dup length [
[ first2 ] [ number>string "Generation " prepend ] bi*
write-total/used/free
] 2each
"Cards" write-total ;
: (code-room.) ( -- )
code-room "Code space" write-total/used/free ;
: write-labelled-size ( n string -- )
[ write-cell write-size ] with-row ;
: room. ( -- )
standard-table-style [
{ "" "Total" "Used" "Free" } write-headings
(data-room.)
(code-room.)
] tabular-output ;
: (code-room.) ( -- )
code-room {
[ "Size:" write-labelled-size ]
[ "Used:" write-labelled-size ]
[ "Total free space:" write-labelled-size ]
[ "Largest free block:" write-labelled-size ]
} spread ;
: heap-stat-step ( counts sizes obj -- )
[ dup size swap class rot at+ ] keep
1 swap class rot at+ ;
PRIVATE>
: room. ( -- )
"==== DATA HEAP" print
standard-table-style [
{ "" "Total" "Used" "Free" } write-headings
(data-room.)
] tabular-output
nl
"==== CODE HEAP" print
standard-table-style [
(code-room.)
] tabular-output ;
: heap-stats ( -- counts sizes )
H{ } clone H{ } clone
[ >r 2dup r> heap-stat-step ] each-object ;