heap-stats. word

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 ;

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"

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 ;

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

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" ]

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);
+}

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);

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)

native/primitives.h

@@ -1,4 +1,4 @@
 extern XT primitives[];
-#define PRIMITIVE_COUNT 190
+#define PRIMITIVE_COUNT 191
 
 CELL primitive_to_xt(CELL primitive);

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 */