improved CPU profiler; memory profiler

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 2d7180aa60f89700bda0566358d442d8462dca29..673606eb1375cb5081213b5357a632dba81be4d1 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -5,6 +5,7 @@
   - directory listings\r
   - index.html\r
   - if a directory is requested and URL does not end with /, redirect\r
+- minimize stage2 initialization code, just move it to source files\r
 \r
 + bignums:\r
 \r

diff --git a/library/cross-compiler.factor b/library/cross-compiler.factor
index 2313aff55fe61b4075f5c10e9f4aadb8eb729a54..9f2d8dac114c2198a5d9628a9dca2bc61f04a5e9 100644 (file)
--- a/library/cross-compiler.factor
+++ b/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,

diff --git a/library/image.factor b/library/image.factor
index e98f06df65c49931a5b92a7ad90c79f8fec91ad0..5465e42678987df222bb0f87bc0376d3cec9f5b4 100644 (file)
--- a/library/image.factor
+++ b/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,) ;

diff --git a/library/platform/native/debugger.factor b/library/platform/native/debugger.factor
index 03cd97b2ae99364a1b08cb395d3ec5393f4905af..09a17db0d5961245eac58bf354c4b365e6886c36 100644 (file)
--- a/library/platform/native/debugger.factor
+++ b/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 . ;

diff --git a/library/platform/native/parse-syntax.factor b/library/platform/native/parse-syntax.factor
index 325738811e119de2827eda7b728f4860ab28af19..5a258dbc6019eff8b9d9503694b2e35ebd301d48 100644 (file)
--- a/library/platform/native/parse-syntax.factor
+++ b/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 ;

diff --git a/library/platform/native/profiler.factor b/library/platform/native/profiler.factor
index 199a411314bc34459ada6f8e7a666a4caec0d0ee..18d6300d8d87c58700f2237b1588957331440498 100644 (file)
--- a/library/platform/native/profiler.factor
+++ b/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 ;
+
+: 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 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. ;
 
-: profile ( quot -- )
-    #! Execute a quotation with the profiler enabled.
-    reset-call-counts
-    callstack vector-length profiling
+: allot-profile ( quot -- )
+    #! Execute a quotation with the memory profiler enabled.
+    reset-counts
+    profile-depth allot-profiling
     call
-    f profiling
-    call-counts [ . ] each ;
+    f allot-profiling
+    allot-counts. ;

diff --git a/native/bignum.h b/native/bignum.h
index feab8de6007e9e95a13d46fed41767e42c6214ed..8810eddc5dd5eb6d42b92a087cc1cce104437074 100644 (file)
--- a/native/bignum.h
+++ b/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);

diff --git a/native/factor.h b/native/factor.h
index cb7912b7dfc57818ab9f83a7aa2fa6ec70838d38..bc5e0010c800ae9af55c6b3ae10e974e7616bf3a 100644 (file)
--- a/native/factor.h
+++ b/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"

diff --git a/native/gc.c b/native/gc.c
index 838030cb7705cad92e87efe9477584b9e39a6b58..a529390197bc28c01cb2d366235d7ca65fad2b11 100644 (file)
--- a/native/gc.c
+++ b/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;
 }

diff --git a/native/gc.h b/native/gc.h
index 9059c8412ec42171ae94bebc046c904ec935e0a5..f90f3fc147d2cf5d6048cd5c17363c7c96114133 100644 (file)
--- a/native/gc.h
+++ b/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);

diff --git a/native/memory.c b/native/memory.c
index 94ba7dd832b3dbb2036f4c2b0fb784953e547d91..cef3c5edc8628bd2cc7cc2ce62dcf3ae0038b7cb 100644 (file)
--- a/native/memory.c
+++ b/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
+}

diff --git a/native/memory.h b/native/memory.h
index c08025f7f27e61ba68e9c04a06359441ac118890..02d96f6be12cf931f58578e97f4a287ecf6702a4 100644 (file)
--- a/native/memory.h
+++ b/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);

diff --git a/native/primitives.c b/native/primitives.c
index 209a1630276b3d3a4a8f4eee5db943a439823bad..6fc8020b0b46b591a6fe79abd86dc147fbdaa7e7 100644 (file)
--- a/native/primitives.c
+++ b/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
 };
 

diff --git a/native/primitives.h b/native/primitives.h
index 9990a9d11ebe2ee9c1cf058d020ac954e1329d3b..7304689766756b974de95ff7eee25f969589f59e 100644 (file)
--- a/native/primitives.h
+++ b/native/primitives.h
@@ -1,4 +1,4 @@
 extern XT primitives[];
-#define PRIMITIVE_COUNT 141
+#define PRIMITIVE_COUNT 144
 
 CELL primitive_to_xt(CELL primitive);

diff --git a/native/run.c b/native/run.c
index 19836cb7f98e496480a19bba37eb7ccaa015df8f..f78d3f9f1978b490520ed99031e86e562c854afb 100644 (file)
--- a/native/run.c
+++ b/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();

diff --git a/native/run.h b/native/run.h
index 94c5ad0d0d19f582935e05d5a8e58af469c321a3..de773c5bc0b95bb9e0dcde92af6becedd93abe6f 100644 (file)
--- a/native/run.h
+++ b/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);

diff --git a/native/word.c b/native/word.c
index 90d0f742c4b0364ad5f644d8e5627a9fa8a30330..90a05a85b68739aec8522b28ff33371d6723c712 100644 (file)
--- a/native/word.c
+++ b/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);

diff --git a/native/word.h b/native/word.h
index 174ac21eeaf37c41eebe03f65e650a3656558926..eece411c3203c7d6005e710b98c47eedae50f0ee 100644 (file)
--- a/native/word.h
+++ b/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);