heap-stats. word

diff --git a/library/cross-compiler.factor b/library/cross-compiler.factor
index 8641246eed67fc77c98b6e9c4a98645d4f7d8c8f..54f5485758fff53d33d49f819d80c8a263a488ed 100644 (file)
--- a/library/cross-compiler.factor
+++ b/library/cross-compiler.factor
@@ -73,6 +73,7 @@ DEFER: type-of
 DEFER: size-of
 DEFER: address-of
 DEFER: dump
+DEFER: heap-stats
 
 IN: strings
 DEFER: str=
@@ -376,6 +377,7 @@ IN: image
         set-alien-2
         alien-1
         set-alien-1
+        heap-stats
     ] [
         swap succ tuck primitive,
     ] each drop ;

diff --git a/library/platform/native/boot-stage2.factor b/library/platform/native/boot-stage2.factor
index d194b4526787f9d0d2b66cb27fe9f5998e03979a..8202e04ede2f0278a5a9a509dfc2fc6881f004fa 100644 (file)
--- a/library/platform/native/boot-stage2.factor
+++ b/library/platform/native/boot-stage2.factor
@@ -109,6 +109,7 @@ USE: stdio
     "/library/telnetd.factor"
     "/library/inferior.factor"
     "/library/platform/native/profiler.factor"
+    "/library/platform/native/heap-stats.factor"
 
     "/library/image.factor"
     "/library/cross-compiler.factor"

diff --git a/library/platform/native/heap-stats.factor b/library/platform/native/heap-stats.factor
new file mode 100644 (file)
index 0000000..91e8a30
--- /dev/null
+++ b/library/platform/native/heap-stats.factor
@@ -0,0 +1,52 @@
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: kernel
+USE: combinators
+USE: kernel
+USE: lists
+USE: math
+USE: namespaces
+USE: prettyprint
+USE: stack
+USE: stdio
+USE: words
+USE: vectors
+USE: unparser
+
+: heap-stat. ( type instances bytes -- )
+    dup 0 = [
+        3drop
+    ] [
+        rot type-name write ": " write
+        unparse write " bytes, " write
+        unparse write " instances" print
+    ] ifte ;
+
+: heap-stats. ( -- )
+    #! Print heap allocation breakdown.
+    0 heap-stats [ dupd uncons heap-stat. succ ] each drop ;

diff --git a/library/platform/native/primitives.factor b/library/platform/native/primitives.factor
index f9937d04dc4aa3fb36093a40312fca22cb4f0405..590ec98703c4bbc80fa3756651966a3398c82cc2 100644 (file)
--- a/library/platform/native/primitives.factor
+++ b/library/platform/native/primitives.factor
@@ -232,6 +232,7 @@ USE: words
     [ set-alien-2            | " n alien off -- " ]
     [ alien-1                | " alien off -- n " ]
     [ set-alien-1            | " n alien off -- " ]
+    [ heap-stats             | " -- instances bytes " ]
 ] [
     unswons "stack-effect" swap set-word-property
 ] each

diff --git a/library/platform/native/types.factor b/library/platform/native/types.factor
index 0c61d82de06580c7c3127c3eea39328288f8b2c4..d4ea3bb2b1905d0d68526a336ae981410f008d42 100644 (file)
--- a/library/platform/native/types.factor
+++ b/library/platform/native/types.factor
@@ -48,10 +48,12 @@ IN: kernel
         [ 0 | "fixnum" ]
         [ 1 | "word" ]
         [ 2 | "cons" ]
+        [ 3 | "object" ]
         [ 4 | "ratio" ]
         [ 5 | "complex" ]
         [ 6 | "f" ]
         [ 7 | "t" ]
+        [ 8 | "array" ]
         [ 9 | "vector" ]
         [ 10 | "string" ]
         [ 11 | "sbuf" ]

diff --git a/native/memory.c b/native/memory.c
index ac47fb20f11b8d68e564c27c8e33bf070d20e756..43cb88652e56e0945a02aa5c5201f4f210dbe3e2 100644 (file)
--- a/native/memory.c
+++ b/native/memory.c
@@ -117,3 +117,49 @@ void primitive_address(void)
 {
        dpush(tag_object(s48_ulong_to_bignum(dpop())));
 }
+
+void primitive_heap_stats(void)
+{
+       int instances[TYPE_COUNT], bytes[TYPE_COUNT];
+       int i;
+       CELL ptr;
+       CELL list = F;
+
+       for(i = 0; i < TYPE_COUNT; i++)
+               instances[i] = 0;
+
+       for(i = 0; i < TYPE_COUNT; i++)
+               bytes[i] = 0;
+
+       ptr = active.base;
+       while(ptr < active.here)
+       {
+               CELL value = get(ptr);
+               CELL size;
+               CELL type;
+
+               if(TAG(value) == HEADER_TYPE)
+               {
+                       size = align8(untagged_object_size(ptr));
+                       type = untag_header(value);
+               }
+               else
+               {
+                       size = CELLS * 2;
+                       type = CONS_TYPE;
+               }
+
+               instances[type]++;
+               bytes[type] += size;
+               ptr += size;
+       }
+
+       for(i = TYPE_COUNT - 1; i >= 0; i--)
+       {
+               list = cons(
+                       cons(tag_fixnum(instances[i]),tag_fixnum(bytes[i])),
+                       list);
+       }
+
+       dpush(list);
+}

diff --git a/native/memory.h b/native/memory.h
index 816139c926d9ad7360971f498b75bc9d56256f46..ebdad4e939e5e5b4d4ae4dc7a2af174a04e486dd 100644 (file)
--- a/native/memory.h
+++ b/native/memory.h
@@ -76,3 +76,4 @@ void primitive_memory_1(void);
 void primitive_set_memory_cell(void);
 void primitive_set_memory_4(void);
 void primitive_set_memory_1(void);
+void primitive_heap_stats(void);

diff --git a/native/primitives.c b/native/primitives.c
index bfd229424c64d94c1fb230dad0012fe604f8de44..e6d542a280f82edfe878a3f303712136152566f8 100644 (file)
--- a/native/primitives.c
+++ b/native/primitives.c
@@ -190,7 +190,8 @@ XT primitives[] = {
        primitive_alien_2,
        primitive_set_alien_2,
        primitive_alien_1,
-       primitive_set_alien_1
+       primitive_set_alien_1,
+       primitive_heap_stats
 };
 
 CELL primitive_to_xt(CELL primitive)

diff --git a/native/primitives.h b/native/primitives.h
index 521fd4500be710a1a8d3a7228b8a14e33498f841..c41f8b479683b3598b4042b856963ede5a3bc84d 100644 (file)
--- a/native/primitives.h
+++ b/native/primitives.h
@@ -1,4 +1,4 @@
 extern XT primitives[];
-#define PRIMITIVE_COUNT 190
+#define PRIMITIVE_COUNT 191
 
 CELL primitive_to_xt(CELL primitive);

diff --git a/native/types.h b/native/types.h
index c25d03e7e36f4506e95913de9c83f2828b1cc80b..c13d01e0c9c84b53ba43f6282ac0856684c88a59 100644 (file)
--- a/native/types.h
+++ b/native/types.h
@@ -34,6 +34,8 @@ CELL T;
 #define DLL_TYPE 15
 #define ALIEN_TYPE 16
 
+#define TYPE_COUNT 17
+
 /* Pseudo-types. For error reporting only. */
 #define INTEGER_TYPE 100 /* FIXNUM or BIGNUM */
 #define RATIONAL_TYPE 101 /* INTEGER or RATIO */