a profiler

TODO.FACTOR.txt

@@ -5,6 +5,8 @@
 - multiple tasks should be able to write to the same port
 - jvm factor -- still supporting httpd?
 - make inferior.factor nicer to use
+- telnetd printing signal 13, and other problems
+- check error callstack, not enough >pop>?
 
 + docs:
 
@@ -35,6 +37,9 @@
 
 + native:
 
+- is the profiler using correct stack depth?
+- bignums
+- >lower, >upper for strings
 - read1
 - telnetd and httpd should use multitasking
 - sbuf-hashcode

library/continuations.factor

@@ -34,7 +34,10 @@ USE: namespaces
 USE: stack
 USE: vectors
 
-: reify datastack >pop> callstack >pop> namestack catchstack ;
+: reify ( quot -- )
+    >r datastack >pop> callstack >pop> namestack catchstack
+    r> call ;
+
 : (callcc) cons cons cons cons swap call ;
 
 : continue0 ( ds rs ns cs -- )
@@ -49,7 +52,7 @@ USE: vectors
     #!
     #! When called, the quotation restores execution state to
     #! the point after the callcc0 call.
-    reify [ continue0 ] (callcc) ;
+    [ [ continue0 ] (callcc) ] reify ;
 
 : continue1 ( obj ds rs ns cs -- obj )
     set-catchstack set-namestack
@@ -64,7 +67,7 @@ USE: vectors
     #! When called, the quotation restores execution state to
     #! the point after the callcc1 call, and places X at the top
     #! of the original datastack.
-    reify [ continue1 ] (callcc) ;
+    [ [ continue1 ] (callcc) ] reify ;
 
 : suspend ( -- )
     "top-level-continuation" get dup [

library/cross-compiler.factor

@@ -81,6 +81,11 @@ DEFER: next-io-task
 IN: parser
 DEFER: str>float
 
+IN: profiler
+DEFER: profiling
+DEFER: call-count
+DEFER: set-call-count
+
 IN: random
 DEFER: init-random
 DEFER: (random-int)
@@ -236,6 +241,9 @@ IN: cross-compiler
         (random-int)
         type-of
         size-of
+        profiling
+        call-count
+        set-call-count
     ] [
         swap succ tuck primitive,
     ] each drop ;

library/platform/native/boot-stage2.factor

@@ -103,6 +103,7 @@ USE: stdio
     "/library/ansi.factor"
     "/library/telnetd.factor"
     "/library/inferior.factor"
+    "/library/platform/native/profiler.factor"
 
     "/library/image.factor"
     "/library/cross-compiler.factor"

library/platform/native/debugger.factor

@@ -79,6 +79,9 @@ USE: vectors
 : no-io-tasks-error ( obj -- )
     "No I/O tasks" print ;
 
+: profiling-disabled-error ( obj -- )
+    drop "Recompile with the EXTRA_CALL_INFO flag." print ;
+
 : kernel-error. ( obj n -- str )
     {
         expired-port-error

library/platform/native/kernel.factor

@@ -97,6 +97,8 @@ USE: vectors
         [ 12 | "port" ]
         [ 13 | "bignum" ]
         [ 14 | "float" ]
+        ! These values are only used by the kernel for error
+        ! reporting.
         [ 100 | "fixnum/bignum" ]
         [ 101 | "fixnum/bignum/ratio" ]
         [ 102 | "fixnum/bignum/ratio/float" ]

library/platform/native/profiler.factor

@@ -0,0 +1,61 @@
+! :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: profiler
+USE: arithmetic
+USE: kernel
+USE: lists
+USE: prettyprint
+USE: stack
+USE: words
+USE: vectors
+
+: reset-call-counts ( -- )
+    vocabs [ words [ 0 swap set-call-count ] each ] each ;
+
+: sort-call-counts ( alist -- alist )
+    [ swap cdr swap cdr > ] sort ;
+
+: call-count, ( word -- )
+    #! Add to constructing list if call count is non-zero.
+    dup call-count dup 0 = [
+        2drop
+    ] [
+        cons ,
+    ] ifte ;
+
+: call-counts ( -- alist )
+    #! Push an alist of all word/call count pairs.
+    [, [ call-count, ] each-word ,] sort-call-counts ;
+
+: profile ( quot -- )
+    #! Execute a quotation with the profiler enabled.
+    reset-call-counts
+    callstack vector-length profiling
+    call
+    f profiling
+    call-counts [ . ] each ;

library/test/threads.factor

@@ -13,4 +13,4 @@ USE: threads
 [ yield 2 "x" set ] in-thread
 [ 2 ] [ yield "x" get ] unit-test
 
-[ flush ] in-thread flush
+! [ flush ] in-thread flush

library/words.factor

@@ -44,3 +44,7 @@ USE: stack
 
 : set-word-vocabulary ( word vocab -- )
     "vocabulary" swap set-word-property ;
+
+: each-word ( quot -- )
+    #! Apply a quotation to each word in the image.
+    vocabs [ words [ swap dup >r call r> ] each ] each drop ;

native/error.c

@@ -29,8 +29,7 @@ void throw_error(CELL error)
 
 	dpush(error);
 	/* Execute the 'throw' word */
-	cpush(callframe);
-	callframe = userenv[BREAK_ENV];
+	call(userenv[BREAK_ENV]);
 	if(callframe == 0)
 	{
 		/* Crash at startup */

native/error.h

@@ -8,6 +8,7 @@
 #define ERROR_SIGNAL (7<<3)
 #define ERROR_IO_TASK_TWICE (8<<3)
 #define ERROR_IO_TASK_NONE (9<<3)
+#define ERROR_PROFILING_DISABLED (10<<3)
 
 void fatal_error(char* msg, CELL tagged);
 void critical_error(char* msg, CELL tagged);

native/factor.h

@@ -36,6 +36,10 @@ typedef unsigned short CHAR;
 
 #define STACK_SIZE 16384
 
+/* This decreases performance slightly but gives more readable backtraces,
+and allows profiling. */
+#define EXTRA_CALL_INFO
+
 #include "error.h"
 #include "memory.h"
 #include "gc.h"

native/memory.c

@@ -54,8 +54,7 @@ void check_memory(void)
 		}
 
 		/* Execute the 'garbage-collection' word */
-		cpush(callframe);
-		callframe = userenv[GC_ENV];
+		call(userenv[GC_ENV]);
 	}
 }
 

native/primitives.c

@@ -2,7 +2,7 @@
 
 XT primitives[] = {
 	undefined,
-	call,
+	docol,
 	primitive_execute,
 	primitive_call,
 	primitive_ifte,
@@ -137,7 +137,10 @@ XT primitives[] = {
 	primitive_init_random,
 	primitive_random_int,
 	primitive_type_of,
-	primitive_size_of
+	primitive_size_of,
+	primitive_profiling,
+	primitive_word_call_count,
+	primitive_set_word_call_count
 };
 
 CELL primitive_to_xt(CELL primitive)

native/primitives.h

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

native/run.c

@@ -5,19 +5,36 @@ void signal_handler(int signal, siginfo_t* siginfo, void* uap)
 	general_error(ERROR_SIGNAL,tag_fixnum(signal));
 }
 
+/* Called from a signal handler. XXX - is this safe? */
+void profiling_step(int signal, siginfo_t* siginfo, void* uap)
+{
+	CELL depth = (cs - cs_bot) / CELLS;
+	int i;
+	CELL obj;
+	for(i = profile_depth; i < depth; i++)
+	{
+		obj = get(cs_bot + i * CELLS);
+		if(TAG(obj) == WORD_TYPE)
+			untag_word(obj)->call_count++;
+	}
+
+	executing->call_count++;
+}
+
 void init_signals(void)
 {
 	struct sigaction custom_sigaction;
-	struct sigaction ign_sigaction;
+	struct sigaction profiling_sigaction;
 	custom_sigaction.sa_sigaction = signal_handler;
 	custom_sigaction.sa_flags = SA_SIGINFO;
-	ign_sigaction.sa_handler = SIG_IGN;
-	ign_sigaction.sa_flags = 0;
+	profiling_sigaction.sa_sigaction = profiling_step;
+	profiling_sigaction.sa_flags = SA_SIGINFO;
 	sigaction(SIGABRT,&custom_sigaction,NULL);
 	sigaction(SIGFPE,&custom_sigaction,NULL);
 	sigaction(SIGBUS,&custom_sigaction,NULL);
 	sigaction(SIGSEGV,&custom_sigaction,NULL);
 	sigaction(SIGPIPE,&custom_sigaction,NULL);
+	sigaction(SIGPROF,&profiling_sigaction,NULL);
 }
 
 void clear_environment(void)
@@ -41,6 +58,9 @@ void run(void)
 		if(callframe == F)
 		{
 			callframe = cpop();
+#ifdef EXTRA_CALL_INFO
+			cpop();
+#endif
 			continue;
 		}
 
@@ -65,29 +85,20 @@ void undefined()
 }
 
 /* XT of compound definitions */
-void call()
+void docol(void)
 {
-	/* tail call optimization */
-	if(callframe != F)
-		cpush(callframe);
-	/* the parameter is the colon def */
-	callframe = executing->parameter;
+	call(executing->parameter);
 }
 
-
 void primitive_execute(void)
 {
-	WORD* word = untag_word(dpop());
-	executing = word;
+	executing = untag_word(dpop());
 	EXECUTE(executing);
 }
 
 void primitive_call(void)
 {
-	CELL calling = dpop();
-	if(callframe != F)
-		cpush(callframe);
-	callframe = calling;
+	call(dpop());
 }
 
 void primitive_ifte(void)
@@ -95,10 +106,7 @@ void primitive_ifte(void)
 	CELL f = dpop();
 	CELL t = dpop();
 	CELL cond = dpop();
-	CELL calling = (untag_boolean(cond) ? t : f);
-	if(callframe != F)
-		cpush(callframe);
-	callframe = calling;
+	call(untag_boolean(cond) ? t : f);
 }
 
 void primitive_getenv(void)
@@ -117,3 +125,29 @@ void primitive_setenv(void)
 		range_error(F,e,USER_ENV);
 	userenv[e] = value;
 }
+
+void primitive_profiling(void)
+{
+#ifndef EXTRA_CALL_INFO
+	general_error(PROFILING_DISABLED,F);
+#else
+	CELL d = dpop();
+	if(d == F)
+	{
+		timerclear(&prof_timer.it_interval);
+		timerclear(&prof_timer.it_value);
+	}
+	else
+	{
+		prof_timer.it_interval.tv_sec = 0;
+		prof_timer.it_interval.tv_usec = 1000;
+		prof_timer.it_value.tv_sec = 0;
+		prof_timer.it_value.tv_usec = 1000;
+
+		profile_depth = to_fixnum(d);
+	}
+
+	if(setitimer(ITIMER_PROF,&prof_timer,NULL) < 0)
+		io_error(__FUNCTION__);
+#endif
+}

native/run.h

@@ -12,6 +12,9 @@
 #define RUNQUEUE_ENV   9 /* used by library only */
 #define ARGS_ENV       10
 
+/* Profiling timer */
+struct itimerval prof_timer;
+
 /* Error handlers restore this */
 sigjmp_buf toplevel;
 
@@ -36,8 +39,13 @@ WORD* executing;
 /* TAGGED user environment data; see getenv/setenv prims */
 CELL userenv[USER_ENV];
 
-void init_signals(void);
+/* Call stack depth to start profile counter from */
+/* This ensures that words in the user's interpreter do not count */
+CELL profile_depth;
 
+void signal_handler(int signal, siginfo_t* siginfo, void* uap);
+void profiling_step(int signal, siginfo_t* siginfo, void* uap);
+void init_signals(void);
 void clear_environment(void);
 
 INLINE CELL dpop(void)
@@ -79,9 +87,22 @@ INLINE CELL cpeek(void)
 	return get(cs - CELLS);
 }
 
+INLINE void call(CELL quot)
+{
+	/* tail call optimization */
+	if(callframe != F)
+	{
+#ifdef EXTRA_CALL_INFO
+		cpush(tag_word(executing));
+#endif
+		cpush(callframe);
+	}
+	callframe = quot;
+}
+
 void run(void);
 void undefined(void);
-void call(void);
+void docol(void);
 void primitive_execute(void);
 void primitive_call(void);
 void primitive_ifte(void);
@@ -89,3 +110,4 @@ void primitive_getenv(void);
 void primitive_setenv(void);
 void primitive_exit(void);
 void primitive_os_env(void);
+void primitive_profiling(void);

native/types.c

@@ -1,24 +1,5 @@
 #include "factor.h"
 
-bool typep(CELL type, CELL tagged)
-{
-	if(type < HEADER_TYPE)
-	{
-		if(TAG(tagged) == type)
-			return true;
-	}
-	else if(type >= HEADER_TYPE)
-	{
-		if(TAG(tagged) == OBJECT_TYPE)
-		{
-			if(untag_header(get(UNTAG(tagged))) == type)
-				return true;
-		}
-	}
-	
-	return false;
-}
-
 CELL type_of(CELL tagged)
 {
 	CELL tag = TAG(tagged);
@@ -28,23 +9,15 @@ CELL type_of(CELL tagged)
 		return untag_header(get(UNTAG(tagged)));
 }
 
+bool typep(CELL type, CELL tagged)
+{
+	return type_of(tagged) == type;
+}
+
 void type_check(CELL type, CELL tagged)
 {
-	if(type < HEADER_TYPE)
-	{
-		if(TAG(tagged) == type)
-			return;
-	}
-	else if(type >= HEADER_TYPE)
-	{
-		if(TAG(tagged) == OBJECT_TYPE)
-		{
-			if(untag_header(get(UNTAG(tagged))) == type)
-				return;
-		}
-	}
-	
-	type_error(type,tagged);
+	if(type_of(tagged) != type)
+		type_error(type,tagged);
 }
 
 /*

native/types.h

@@ -38,8 +38,8 @@ CELL T;
 #define REAL_TYPE 102 /* RATIONAL or FLOAT */
 #define NUMBER_TYPE 103 /* COMPLEX or REAL */
 
-bool typep(CELL type, CELL tagged);
 CELL type_of(CELL tagged);
+bool typep(CELL type, CELL tagged);
 void type_check(CELL type, CELL tagged);
 
 INLINE CELL tag_boolean(CELL untagged)

native/word.c

@@ -7,6 +7,7 @@ WORD* word(CELL primitive, CELL parameter, CELL plist)
 	word->primitive = primitive;
 	word->parameter = parameter;
 	word->plist = plist;
+	word->call_count = 0;
 
 	return word;
 }
@@ -68,6 +69,17 @@ void primitive_set_word_plist(void)
 	word->plist = dpop();
 }
 
+void primitive_word_call_count(void)
+{
+	drepl(tag_fixnum(untag_word(dpeek())->call_count));
+}
+
+void primitive_set_word_call_count(void)
+{
+	WORD* word = untag_word(dpop());
+	word->call_count = to_fixnum(dpop());
+}
+
 void fixup_word(WORD* word)
 {
 	word->xt = primitive_to_xt(word->primitive);

native/word.h

@@ -11,6 +11,8 @@ typedef struct {
 	CELL parameter;
 	/* TAGGED property list for library code */
 	CELL plist;
+	/* UNTAGGED call count incremented by profiler */
+	CELL call_count;
 } WORD;
 
 INLINE WORD* untag_word(CELL tagged)
@@ -26,8 +28,6 @@ INLINE CELL tag_word(WORD* word)
 
 WORD* word(CELL primitive, CELL parameter, CELL plist);
 void update_xt(WORD* word);
-void fixup_word(WORD* word);
-void collect_word(WORD* word);
 void primitive_wordp(void);
 void primitive_word(void);
 void primitive_word_primitive(void);
@@ -36,3 +36,7 @@ void primitive_word_parameter(void);
 void primitive_set_word_parameter(void);
 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 fixup_word(WORD* word);
+void collect_word(WORD* word);