From c66ded6bf8e16b36034f3f9379d65f5a0e20e21c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 23 Aug 2004 05:13:09 +0000 Subject: [PATCH] a profiler --- TODO.FACTOR.txt | 5 ++ library/continuations.factor | 9 ++- library/cross-compiler.factor | 8 +++ library/platform/native/boot-stage2.factor | 1 + library/platform/native/debugger.factor | 3 + library/platform/native/kernel.factor | 2 + library/platform/native/profiler.factor | 61 ++++++++++++++++++ library/test/threads.factor | 2 +- library/words.factor | 4 ++ native/error.c | 3 +- native/error.h | 1 + native/factor.h | 4 ++ native/memory.c | 3 +- native/primitives.c | 7 +- native/primitives.h | 2 +- native/run.c | 74 ++++++++++++++++------ native/run.h | 26 +++++++- native/types.c | 41 ++---------- native/types.h | 2 +- native/word.c | 12 ++++ native/word.h | 8 ++- 21 files changed, 208 insertions(+), 70 deletions(-) create mode 100644 library/platform/native/profiler.factor diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 7f3cc52498..8fdd3f4457 100644 --- a/TODO.FACTOR.txt +++ b/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 diff --git a/library/continuations.factor b/library/continuations.factor index 40a68b9a9f..dd60d07f79 100644 --- a/library/continuations.factor +++ b/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 [ diff --git a/library/cross-compiler.factor b/library/cross-compiler.factor index bfa08c0cc5..36439f0041 100644 --- a/library/cross-compiler.factor +++ b/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 ; diff --git a/library/platform/native/boot-stage2.factor b/library/platform/native/boot-stage2.factor index 432fc170fe..82819170d0 100644 --- a/library/platform/native/boot-stage2.factor +++ b/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" diff --git a/library/platform/native/debugger.factor b/library/platform/native/debugger.factor index 3665e718fa..1f43ca1a81 100644 --- a/library/platform/native/debugger.factor +++ b/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 diff --git a/library/platform/native/kernel.factor b/library/platform/native/kernel.factor index 1eef3d7f44..d27fd6a7a4 100644 --- a/library/platform/native/kernel.factor +++ b/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" ] diff --git a/library/platform/native/profiler.factor b/library/platform/native/profiler.factor new file mode 100644 index 0000000000..5cecf85614 --- /dev/null +++ b/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 ; diff --git a/library/test/threads.factor b/library/test/threads.factor index 14f9b116ed..da6160df27 100644 --- a/library/test/threads.factor +++ b/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 diff --git a/library/words.factor b/library/words.factor index 33d1a39e8d..dfdbaa49d9 100644 --- a/library/words.factor +++ b/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 ; diff --git a/native/error.c b/native/error.c index faf68fdf62..dff9bcc960 100644 --- a/native/error.c +++ b/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 */ diff --git a/native/error.h b/native/error.h index 6430778cd4..610fe2f126 100644 --- a/native/error.h +++ b/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); diff --git a/native/factor.h b/native/factor.h index 7e85dc8ed9..22477b32e0 100644 --- a/native/factor.h +++ b/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" diff --git a/native/memory.c b/native/memory.c index c1b4e7532e..d699a28a91 100644 --- a/native/memory.c +++ b/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]); } } diff --git a/native/primitives.c b/native/primitives.c index d56afa9ba6..17893c7648 100644 --- a/native/primitives.c +++ b/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) diff --git a/native/primitives.h b/native/primitives.h index 20cb799615..baeaa8997b 100644 --- a/native/primitives.h +++ b/native/primitives.h @@ -1,4 +1,4 @@ extern XT primitives[]; -#define PRIMITIVE_COUNT 137 +#define PRIMITIVE_COUNT 140 CELL primitive_to_xt(CELL primitive); diff --git a/native/run.c b/native/run.c index 5c2544cb8c..48ffd4e699 100644 --- a/native/run.c +++ b/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 +} diff --git a/native/run.h b/native/run.h index 5ae6d40677..7ccd4eafb8 100644 --- a/native/run.h +++ b/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); diff --git a/native/types.c b/native/types.c index 520a9912be..d14533e944 100644 --- a/native/types.c +++ b/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); } /* diff --git a/native/types.h b/native/types.h index ad8a72861e..4b8d55a5b0 100644 --- a/native/types.h +++ b/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) diff --git a/native/word.c b/native/word.c index 363d2c588b..90d0f742c4 100644 --- a/native/word.c +++ b/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); diff --git a/native/word.h b/native/word.h index 55af1730f0..174ac21eea 100644 --- a/native/word.h +++ b/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);