improved CPU profiler; memory profiler

TODO.FACTOR.txt

@@ -5,6 +5,7 @@
   - directory listings
   - index.html
   - if a directory is requested and URL does not end with /, redirect
+- minimize stage2 initialization code, just move it to source files
 
 + bignums:
 

library/cross-compiler.factor

@@ -85,9 +85,12 @@ IN: parser
 DEFER: str>float
 
 IN: profiler
-DEFER: profiling
+DEFER: call-profiling
 DEFER: call-count
 DEFER: set-call-count
+DEFER: allot-profiling
+DEFER: allot-count
+DEFER: set-allot-count
 
 IN: random
 DEFER: init-random
@@ -244,9 +247,12 @@ IN: cross-compiler
         (random-int)
         type-of
         size-of
-        profiling
+        call-profiling
         call-count
         set-call-count
+        allot-profiling
+        allot-count
+        set-allot-count
         dump
     ] [
         swap succ tuck primitive,

library/image.factor

@@ -294,7 +294,9 @@ IN: cross-compiler
     r> ( primitive -- ) emit
     r> ( parameter -- ) emit
     ( plist -- ) emit
-    0 emit ( padding ) ;
+    0 emit ( padding )
+    0 emit
+    0 emit ;
 
 : primitive, ( word primitive -- ) f (worddef,) ;
 : compound, ( word definition -- ) 1 swap (worddef,) ;

library/platform/native/debugger.factor

@@ -84,7 +84,7 @@ USE: words
     "Operating system signal " write . ;
 
 : profiling-disabled-error ( obj -- )
-    drop "Recompile with the EXTRA_CALL_INFO flag." print ;
+    drop "Recompile with the FACTOR_PROFILER flag." print ;
 
 : negative-array-size-error ( obj -- )
     "Cannot allocate array with negative size " write . ;

library/platform/native/parse-syntax.factor

@@ -166,11 +166,17 @@ USE: unparser
 
 : ! until-eol drop ; parsing
 
+: documentation+ ( str word -- )
+    [
+        "documentation" swap word-property [
+            swap "\n" swap cat3
+        ] when*
+    ] keep
+    "documentation" swap set-word-property ;
+
 : parsed-documentation ( parsed str -- parsed )
     over doc-comment-here? [
-        "documentation" word word-property [
-            swap "\n" swap cat3
-        ] when* "documentation" word set-word-property
+        word documentation+
     ] [
         drop
     ] ifte ;

library/platform/native/profiler.factor

@@ -30,15 +30,19 @@ USE: combinators
 USE: kernel
 USE: lists
 USE: math
+USE: namespaces
 USE: prettyprint
 USE: stack
 USE: words
 USE: vectors
 
-: reset-call-counts ( -- )
-    vocabs [ words [ 0 swap set-call-count ] each ] each ;
+! The variable "profile-top-only" toggles between
+! culminative counts, and top of call stack counts.
 
-: sort-call-counts ( alist -- alist )
+: reset-counts ( -- )
+    [ 0 over set-call-count 0 swap set-allot-count ] each-word ;
+
+: sort-counts ( alist -- alist )
     [ swap cdr swap cdr > ] sort ;
 
 : call-count, ( word -- )
@@ -49,14 +53,44 @@ USE: vectors
         cons ,
     ] ifte ;
 
-: call-counts ( -- alist )
-    #! Push an alist of all word/call count pairs.
-    [, [ call-count, ] each-word ,] sort-call-counts ;
+: counts. ( alist -- )
+    sort-counts [ . ] each ;
 
-: profile ( quot -- )
-    #! Execute a quotation with the profiler enabled.
-    reset-call-counts
-    callstack vector-length profiling
+: call-counts. ( -- )
+    #! Print word/call count pairs.
+    [, [ call-count, ] each-word ,] counts. ;
+
+: profile-depth ( -- n )
+    "profile-top-only" get [
+        -1
+    ] [
+        callstack vector-length
+    ] ifte ;
+
+: call-profile ( quot -- )
+    #! Execute a quotation with the CPU profiler enabled.
+    reset-counts
+    profile-depth call-profiling
     call
-    f profiling
-    call-counts [ . ] each ;
+    f call-profiling
+    call-counts. ;
+
+: allot-count, ( word -- )
+    #! Add to constructing list if allot count is non-zero.
+    dup allot-count dup 0 = [
+        2drop
+    ] [
+        cons ,
+    ] ifte ;
+
+: allot-counts. ( -- alist )
+    #! Print word/allot count pairs.
+    [, [ allot-count, ] each-word ,] counts. ;
+
+: allot-profile ( quot -- )
+    #! Execute a quotation with the memory profiler enabled.
+    reset-counts
+    profile-depth allot-profiling
+    call
+    f allot-profiling
+    allot-counts. ;

native/bignum.h

@@ -1,13 +1,13 @@
+CELL bignum_zero;
+CELL bignum_pos_one;
+CELL bignum_neg_one;
+
 INLINE ARRAY* untag_bignum(CELL tagged)
 {
 	type_check(BIGNUM_TYPE,tagged);
 	return (ARRAY*)UNTAG(tagged);
 }
 
-CELL bignum_zero;
-CELL bignum_pos_one;
-CELL bignum_neg_one;
-
 void primitive_bignump(void);
 ARRAY* to_bignum(CELL tagged);
 void primitive_to_bignum(void);

native/factor.h

@@ -38,7 +38,7 @@ typedef unsigned short CHAR;
 
 /* This decreases performance slightly but gives more readable backtraces,
 and allows profiling. */
-#define EXTRA_CALL_INFO
+#define FACTOR_PROFILER
 
 #include "memory.h"
 #include "error.h"

native/gc.c

@@ -137,6 +137,8 @@ void collect_roots(void)
 
 void primitive_gc(void)
 {
+	gc_in_progress = true;
+
 	flip_zones();
 	scan = active->here = active->base;
 	collect_roots();
@@ -147,4 +149,6 @@ void primitive_gc(void)
 		collect_next();
 	}
 	gc_debug("gc done",0);
+
+	gc_in_progress = false;
 }

native/gc.h

@@ -1,4 +1,5 @@
 CELL scan;
+bool gc_in_progress;
 
 void* copy_untagged_object(void* pointer, CELL size);
 void copy_object(CELL* handle);

native/memory.c

@@ -38,8 +38,31 @@ void init_arena(CELL size)
 	z1 = zalloc(size);
 	z2 = zalloc(size);
 	active = z1;
+	allot_profiling = false;
+	gc_in_progress = false;
 }
 
+#ifdef FACTOR_PROFILER
+void allot_profile_step(CELL a)
+{
+	CELL depth = (cs - cs_bot) / CELLS;
+	int i;
+	CELL obj;
+
+	if(gc_in_progress)
+		return;
+
+	for(i = profile_depth; i < depth; i++)
+	{
+		obj = get(cs_bot + i * CELLS);
+		if(TAG(obj) == WORD_TYPE)
+			untag_word(obj)->allot_count += a;
+	}
+
+	executing->allot_count += a;
+}
+#endif
+
 void check_memory(void)
 {
 	if(active->here > active->alarm)
@@ -84,3 +107,19 @@ void primitive_room(void)
 	dpush(tag_fixnum_or_bignum(active->limit - active->here));
 	dpush(tag_fixnum_or_bignum(active->limit - active->base));
 }
+
+void primitive_allot_profiling(void)
+{
+#ifndef FACTOR_PROFILER
+	general_error(ERROR_PROFILING_DISABLED,F);
+#else
+	CELL d = dpop();
+	if(d == F)
+		allot_profiling = false;
+	else
+	{
+		allot_profiling = true;
+		profile_depth = to_fixnum(d);
+	}
+#endif
+}

native/memory.h

@@ -10,12 +10,15 @@ ZONE* z2;
 ZONE* active; /* either z1 or z2 */
 ZONE* prior; /* if active==z1, z2; if active==z2, z1 */
 
+bool allot_profiling;
+
 void* alloc_guarded(CELL size);
 ZONE* zalloc(CELL size);
 void init_arena(CELL size);
 void flip_zones();
 
 void check_memory(void);
+void allot_profile_step(CELL a);
 
 INLINE CELL align8(CELL a)
 {
@@ -26,6 +29,10 @@ INLINE void* allot(CELL a)
 {
 	CELL h = active->here;
 	active->here += align8(a);
+#ifdef FACTOR_PROFILER
+	if(allot_profiling)
+		allot_profile_step(align8(a));
+#endif
 	check_memory();
 	return (void*)h;
 }
@@ -63,3 +70,4 @@ INLINE void bput(CELL where, char what)
 bool in_zone(ZONE* z, CELL pointer);
 
 void primitive_room(void);
+void primitive_allot_profiling(void);

native/primitives.c

@@ -138,9 +138,12 @@ XT primitives[] = {
 	primitive_random_int,
 	primitive_type_of,
 	primitive_size_of,
-	primitive_profiling,
+	primitive_call_profiling,
 	primitive_word_call_count,
 	primitive_set_word_call_count,
+	primitive_allot_profiling,
+	primitive_word_allot_count,
+	primitive_set_word_allot_count,
 	primitive_dump
 };
 

native/primitives.h

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

native/run.c

@@ -6,7 +6,7 @@ void signal_handler(int signal, siginfo_t* siginfo, void* uap)
 }
 
 /* Called from a signal handler. XXX - is this safe? */
-void profiling_step(int signal, siginfo_t* siginfo, void* uap)
+void call_profiling_step(int signal, siginfo_t* siginfo, void* uap)
 {
 	CELL depth = (cs - cs_bot) / CELLS;
 	int i;
@@ -28,7 +28,7 @@ void init_signals(void)
 	struct sigaction ign_sigaction;
 	custom_sigaction.sa_sigaction = signal_handler;
 	custom_sigaction.sa_flags = SA_SIGINFO;
-	profiling_sigaction.sa_sigaction = profiling_step;
+	profiling_sigaction.sa_sigaction = call_profiling_step;
 	profiling_sigaction.sa_flags = SA_SIGINFO;
 	ign_sigaction.sa_handler = SIG_IGN;
 	sigaction(SIGABRT,&custom_sigaction,NULL);
@@ -61,7 +61,7 @@ void run(void)
 		if(callframe == F)
 		{
 			callframe = cpop();
-#ifdef EXTRA_CALL_INFO
+#ifdef FACTOR_PROFILER
 			cpop();
 #endif
 			continue;
@@ -129,9 +129,9 @@ void primitive_setenv(void)
 	userenv[e] = value;
 }
 
-void primitive_profiling(void)
+void primitive_call_profiling(void)
 {
-#ifndef EXTRA_CALL_INFO
+#ifndef FACTOR_PROFILER
 	general_error(ERROR_PROFILING_DISABLED,F);
 #else
 	CELL d = dpop();

native/run.h

@@ -87,7 +87,7 @@ INLINE void call(CELL quot)
 	/* tail call optimization */
 	if(callframe != F)
 	{
-#ifdef EXTRA_CALL_INFO
+#ifdef FACTOR_PROFILER
 		cpush(tag_word(executing));
 #endif
 		cpush(callframe);
@@ -96,7 +96,7 @@ INLINE void call(CELL quot)
 }
 
 void signal_handler(int signal, siginfo_t* siginfo, void* uap);
-void profiling_step(int signal, siginfo_t* siginfo, void* uap);
+void call_profiling_step(int signal, siginfo_t* siginfo, void* uap);
 void init_signals(void);
 void clear_environment(void);
 
@@ -110,4 +110,4 @@ void primitive_getenv(void);
 void primitive_setenv(void);
 void primitive_exit(void);
 void primitive_os_env(void);
-void primitive_profiling(void);
+void primitive_call_profiling(void);

native/word.c

@@ -80,6 +80,17 @@ void primitive_set_word_call_count(void)
 	word->call_count = to_fixnum(dpop());
 }
 
+void primitive_word_allot_count(void)
+{
+	drepl(tag_fixnum(untag_word(dpeek())->allot_count));
+}
+
+void primitive_set_word_allot_count(void)
+{
+	WORD* word = untag_word(dpop());
+	word->allot_count = to_fixnum(dpop());
+}
+
 void fixup_word(WORD* word)
 {
 	word->xt = primitive_to_xt(word->primitive);

native/word.h

@@ -13,6 +13,9 @@ typedef struct {
 	CELL plist;
 	/* UNTAGGED call count incremented by profiler */
 	CELL call_count;
+	/* UNTAGGED amount of memory allocated in word */
+	CELL allot_count;
+	CELL padding;
 } WORD;
 
 INLINE WORD* untag_word(CELL tagged)
@@ -38,5 +41,7 @@ void primitive_word_plist(void);
 void primitive_set_word_plist(void);
 void primitive_word_call_count(void);
 void primitive_set_word_call_count(void);
+void primitive_word_allot_count(void);
+void primitive_set_word_allot_count(void);
 void fixup_word(WORD* word);
 void collect_word(WORD* word);