From a48120c80b2886c56adc4b52ee092a020e78de1d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Mon, 7 Apr 2008 21:04:51 -0500
Subject: [PATCH] Improve memory tooL

---
 extra/tools/memory/memory-tests.factor |  4 ++
 extra/tools/memory/memory.factor       | 58 ++++++++++++++++++--------
 2 files changed, 44 insertions(+), 18 deletions(-)

diff --git a/extra/tools/memory/memory-tests.factor b/extra/tools/memory/memory-tests.factor
index 9efbf63f7f..60b54c2a0d 100644
--- a/extra/tools/memory/memory-tests.factor
+++ b/extra/tools/memory/memory-tests.factor
@@ -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
diff --git a/extra/tools/memory/memory.factor b/extra/tools/memory/memory.factor
index 2077ea497e..b8fdcab280 100644
--- a/extra/tools/memory/memory.factor
+++ b/extra/tools/memory/memory.factor
@@ -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 ;