Improved profiler doesn't require all words to be recompiled to enable/disable

core/alien/compiler/compiler.factor

@@ -383,6 +383,8 @@ TUPLE: callback-context ;
 
 : generate-callback ( node -- )
     dup alien-callback-xt dup rot [
+        %save-xt
+        %prologue-later
         dup alien-stack-frame [
             init-templates
             dup registers>objects

core/bootstrap/image/image.factor

@@ -210,8 +210,9 @@ M: f '
         dup word-def ' ,
         dup word-props ' ,
         f ' ,
-        0 ,
+        0 , ! count
-        0 ,
+        0 , ! xt
+        0 , ! code
     ] { } make
     \ word type-number object tag-number
     [ emit-seq ] emit-object
@@ -307,7 +308,8 @@ M: quotation '
         quotation type-number object tag-number [
             emit ! array
             f ' emit ! compiled?
-            0 emit ! XT
+            0 emit ! xt
+            0 emit ! code
         ] emit-object
     ] cache ;
 

core/cpu/architecture/architecture.factor

@@ -5,6 +5,9 @@ namespaces sequences layouts system hashtables classes alien
 byte-arrays bit-arrays float-arrays combinators words ;
 IN: cpu.architecture
 
+: set-profiler-prologues ( n -- )
+    39 setenv ;
+
 SYMBOL: compiler-backend
 
 ! A pseudo-register class for parameters spilled on the stack

core/cpu/arm/architecture/architecture.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays cpu.arm.assembler compiler
-kernel kernel.private math namespaces words
+kernel kernel.private math namespaces words words.private
-words.private generator.registers generator.fixup generator
+generator.registers generator.fixup generator cpu.architecture
-cpu.architecture system layouts ;
+system layouts ;
 IN: cpu.arm.architecture
 
 TUPLE: arm-backend ;
@@ -86,18 +86,13 @@ M: arm-backend %epilogue ( n -- )
 : %alien-global ( symbol dll reg -- )
     [ compile-dlsym ] keep dup 0 <+> LDR ;
 
-M: arm-backend %profiler-prologue ( word -- )
+M: arm-backend %profiler-prologue ( -- )
     #! We can clobber R0 here since it is undefined at the start
     #! of a word.
-    "end" define-label
-    "profiling" f R12 %alien-global
-    R12 0 CMP
-    "end" get EQ B
     R12 load-indirect
     R0 R12 profile-count-offset <+> LDR
     R0 R0 1 v>operand ADD
-    R0 R12 profile-count-offset <+> STR
+    R0 R12 profile-count-offset <+> STR ;
-    "end" resolve-label ;
 
 M: arm-backend %call-label ( label -- ) BL ;
 

core/cpu/arm/arm.factor

@@ -52,3 +52,5 @@ T{ arm-backend } compiler-backend set-global
 "arm-variant" get "arm5" = [
     t have-BLX? set-global
 ] when
+
+7 cells set-profiler-prologue

core/cpu/ppc/architecture/architecture.factor

@@ -103,16 +103,10 @@ M: ppc-backend %epilogue ( n -- )
     0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
 
 M: ppc-backend %profiler-prologue ( word -- )
-    "end" define-label
-    "profiling" f 3 %load-dlsym
-    3 3 0 LWZ
-    0 3 0 CMPI
-    "end" get BEQ
     3 load-indirect
     4 3 profile-count-offset LWZ
     4 4 1 v>operand ADDI
-    4 3 profile-count-offset STW
+    4 3 profile-count-offset STW ;
-    "end" resolve-label ;
 
 M: ppc-backend %call-label ( label -- ) BL ;
 

core/cpu/ppc/ppc.factor

@@ -13,3 +13,5 @@ namespaces alien.c-types kernel system combinators ;
 } cond
 
 T{ ppc-backend } compiler-backend set-global
+
+6 cells set-profiler-prologues

core/cpu/x86/32/32.factor

@@ -281,3 +281,5 @@ T{ x86-backend f 4 } compiler-backend set-global
         " - no" print
     ] if
 ] unless
+
+9 set-profiler-prologues

core/cpu/x86/64/64.factor

@@ -204,3 +204,5 @@ M: struct-type flatten-value-type ( type -- seq )
             "void*" "double" ? c-type ,
         ] each
     ] if ;
+
+14 set-profiler-prologues

core/cpu/x86/architecture/architecture.factor

@@ -71,13 +71,8 @@ M: x86-backend %prepare-alien-invoke
     temp-reg v>operand 3 cells [+] rs-reg MOV ;
 
 M: x86-backend %profiler-prologue ( word -- )
-    "end" define-label
-    "profiling" f temp-reg v>operand %alien-global
-    temp-reg v>operand 0 CMP
-    "end" get JE
     temp-reg load-literal
-    temp-reg v>operand profile-count-offset [+] 1 v>operand ADD
+    temp-reg v>operand profile-count-offset [+] 1 v>operand ADD ;
-    "end" resolve-label ;
 
 M: x86-backend %call-label ( label -- ) CALL ;
 

core/generator/generator-docs.factor

@@ -5,8 +5,7 @@ IN: generator
 ARTICLE: "generator" "Compiled code generator"
 "Most of the words in the " { $vocab-link "generator" } " vocabulary are internal to the compiler and user code has no reason to call them."
 $nl
-"Debugging information can be enabled or disabled; these hooks are used by " { $link "profiling" } " and " { $link "tools.deploy" } ":"
+"Debugging information can be enabled or disabled; this hook is used by " { $link "tools.deploy" } ":"
-{ $subsection profiler-prologues }
 { $subsection compiled-stack-traces }
 "Assembler intrinsics can be defined for low-level optimization:"
 { $subsection define-intrinsic }
@@ -66,9 +65,6 @@ HELP: generate-nodes
 { $description "Recursively generate machine code for a dataflow graph." }
 { $notes "This word can only be called from inside the quotation passed to " { $link generate-1 } "." } ;
 
-HELP: profiler-prologue
-{ $description "Compiles a prologue which increment's the currently compiling word's call count, if such prologues were enabled by setting " { $link profiler-prologues } " to a true value." } ;
-
 HELP: generate
 { $values { "word" word } { "label" word } { "node" "a dataflow node" } }
 { $description "Generates machine code for " { $snippet "label" } " from " { $snippet "node" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ;

core/generator/generator.factor

@@ -33,17 +33,17 @@ t compiled-stack-traces set-global
 : init-generator ( -- )
     V{ } clone literal-table set
     V{ } clone word-table set
-    compiled-stack-traces get
+    compiled-stack-traces get compiling-word get f ?
-    [ compiling-word get ] [ f ] if
     literal-table get push ;
 
+: profiler-prologue ( -- )
+    literal-table get first %profiler-prologue ;
+
 : generate-1 ( word label node quot -- )
     pick f save-xt [
         roll compiling-word set
         pick compiling-label set
         init-generator
-        %save-xt
-        %prologue-later
         call
         literal-table get >array
         word-table get >array
@@ -54,17 +54,12 @@ GENERIC: generate-node ( node -- next )
 : generate-nodes ( node -- )
     [ node@ generate-node ] iterate-nodes end-basic-block ;
 
-SYMBOL: profiler-prologues
-
-: profiler-prologue ( -- )
-    profiler-prologues get-global [
-        compiling-word get %profiler-prologue
-    ] when ;
-
 : generate ( word label node -- )
     [
         init-templates
         profiler-prologue
+        %save-xt
+        %prologue-later
         current-label-start define-label
         current-label-start resolve-label
         [ generate-nodes ] with-node-iterator
@@ -188,6 +183,8 @@ M: #if generate-node
     gensym [
         rot [
             copy-templates
+            %save-xt
+            %prologue-later
             [ generate-nodes ] with-node-iterator
         ] generate-1
     ] keep ;

extra/tools/profiler/profiler-docs.factor

@@ -1,18 +1,15 @@
 USING: tools.profiler.private tools.time help.markup help.syntax
-quotations io strings words definitions generator ;
+quotations io strings words definitions ;
 IN: tools.profiler
 
 ARTICLE: "profiling" "Profiling code" 
-"A simple call counting profiler is included. Both compiled and interpreted code can be profiled. There are a number of limitations when profiling compiled code:"
+"The " { $vocab-link "tools.profiler" } " vocabulary implements a simple call counting profiler. The profiler has three main limitations:"
 { $list
-    { "Calls to " { $link POSTPONE: inline } " words are not counted" }
+    "Calls to primitives are not counted."
-    "Calls to primitives are not counted"
+    { "Calls to " { $link POSTPONE: inline } " words from words compiled with the optimizing compiler are not counted." }
+    "Certain types of tail-recursive words compiled with the optimizing compiler will only count the initial invocation of the word, not every tail call."
 }
-"The profiler must be enabled before use:"
+"Quotations can be passed to a combinator which calls them with word call counting enabled:"
-{ $subsection enable-profiler }
-"Since enabling the profiler reduces performance, it should be disabled after use:"
-{ $subsection disable-profiler }
-"While enabled, a combinator which counts all calls made by a quotation can be used:"
 { $subsection profile }
 "After a quotation has been profiled, call counts can be presented in various ways:"
 { $subsection profile. }
@@ -34,20 +31,9 @@ HELP: counters.
 { $values { "assoc" "an association list mapping words to integers" } }
 { $description "Prints an association list of call counts to the " { $link stdio } " stream." } ;
 
-HELP: enable-profiler
-{ $description "Recompiles all words in the dictionary to include a stub which increments the call count during profiling. Once this is done, the " { $link profile } " combinator may be used." }
-{ $notes "Performance is affected when profiling is enabled, so profiling should only be enabled when necessary." } ;
-
-HELP: disable-profiler
-{ $description "Recompiles all words in the dictionary to exclude a stub which increments the call count during profiling. This should be done when you no longer wish to use the " { $link profile } " combinator." } ;
-
-HELP: check-profiler
-{ $description "Throws an error if the profiler has not yet been enabled by a call to " { $link enable-profiler } "." } ;
-
 HELP: profile
 { $values { "quot" quotation } }
-{ $description "Calls the quotation while collecting word call counts, which can then be displayed using " { $link profile. } " or related words." }
+{ $description "Calls the quotation while collecting word call counts, which can then be displayed using " { $link profile. } " or related words." } ;
-{ $errors "Throws an error if the profiler has not been enabled by a prior call to " { $link enable-profiler } "." } ;
 
 HELP: profile.
 { $description "Prints a table of call counts from the most recent invocation of " { $link profile } "." } ;
@@ -68,9 +54,6 @@ HELP: vocabs-profile.
 
 HELP: profiling ( ? -- )
 { $values { "?" "a boolean" } }
-{ $description "Internal primitive to switch on call counting. This word should not be used; instead see " { $link enable-profiler } ", " { $link profile } " and " { $link disable-profiler } "." } ;
+{ $description "Internal primitive to switch on call counting. This word should not be used; instead use " { $link profile } "." } ;
 
 { time profile } related-words
-
-HELP: profiler-prologues
-{ $var-description "If set, each word will be compiled with an extra prologue which checks if profiling is enabled, and if so, increments the word's call count. This variable is off by default. It should never be set directly; " { $link enable-profiler } " and " { $link disable-profiler } " should be used instead." } ;

extra/tools/profiler/profiler-tests.factor

@@ -2,8 +2,6 @@ IN: temporary
 USING: tools.profiler tools.test kernel memory math threads
 alien tools.profiler.private ;
 
-enable-profiler
-
 [ ] [ [ 10 [ data-gc ] times ] profile ] unit-test
 
 [ ] [ [ 1000 sleep ] profile ] unit-test 
@@ -28,5 +26,3 @@ enable-profiler
 ] profile
 
 [ 1 ] [ \ foobar profile-counter ] unit-test
-
-disable-profiler

extra/tools/profiler/profiler.factor

@@ -1,13 +1,12 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: words sequences math prettyprint kernel arrays
+USING: words sequences math prettyprint kernel arrays io
-io io.styles namespaces assocs kernel.private generator
+io.styles namespaces assocs kernel.private strings combinators
-compiler strings combinators sorting math.parser
+sorting math.parser vocabs definitions tools.profiler.private ;
-vocabs definitions tools.profiler.private ;
 IN: tools.profiler
 
-: reset-counters ( -- )
+: profile ( quot -- )
-    all-words [ 0 swap set-profile-counter ] each ;
+    [ t profiling call ] [ f profiling ] [ ] cleanup ;
 
 : counters ( words -- assoc )
     [ dup profile-counter ] { } map>assoc ;
@@ -40,26 +39,6 @@ M: string (profile.)
         [ counter. ] assoc-each
     ] tabular-output ;
 
-: enable-profiler ( -- )
-    t profiler-prologues set-global recompile-all
-    "Profiler enabled; use disable-profiler to disable" print ;
-
-: disable-profiler ( -- )
-    f profiler-prologues set-global recompile-all ;
-
-: check-profiler ( -- )
-    profiler-prologues get-global [
-        "Enable the profiler by calling enable-profiler first"
-        throw
-    ] unless ;
-
-: profile ( quot -- )
-    check-profiler
-    reset-counters
-    t profiling
-    call
-    f profiling ;
-
 : profile. ( -- )
     "Call counts for all words:" print
     all-words counters counters. ;

extra/ui/tools/profiler/profiler.factor

@@ -24,23 +24,11 @@ TUPLE: profiler-gadget pane ;
 : com-vocabs-profile ( gadget -- )
     [ vocabs-profile. ] with-profiler-pane ;
 
-\ enable-profiler H{
-    { +nullary+ t }
-    { +listener+ t }
-} define-command
-
-\ disable-profiler H{
-    { +nullary+ t }
-    { +listener+ t }
-} define-command
-
 : profiler-help "ui-profiler" help-window ;
 
 \ profiler-help H{ { +nullary+ t } } define-command
 
 profiler-gadget "toolbar" f {
-    { f enable-profiler }
-    { f disable-profiler }
     { f com-full-profile }
     { f com-vocabs-profile }
     { T{ key-down f f "F1" } profiler-help }

extra/ui/tools/tools-docs.factor

@@ -65,7 +65,7 @@ $nl
 ARTICLE: "ui-profiler" "UI profiler" 
 "The graphical profiler is based on the terminal profiler (see " { $link "profiling" } ") and adds more convenient browsing of profiler results."
 $nl
-"The profiler must be enabled before use. Once the profiler has been enabled, enter a piece of code in the listener input area and press " { $operation com-profile } "."
+"To use the profiler, enter a piece of code in the listener input area and press " { $operation com-profile } "."
 $nl
 "Vocabulary and word presentations in the profiler pane can be clicked on to show profiler results pertaining to the object in question. Clicking a vocabulary in the profiler yields the same output as the " { $link vocab-profile. } " word, and clicking a word yields the same output as the " { $link usage-profile. } " word. Consult " { $link "profiling" } " for details."
 { $command-map profiler-gadget "toolbar" } ;

vm/callstack.c

@@ -95,14 +95,19 @@ DEFINE_PRIMITIVE(set_callstack)
 	critical_error("Bug in set_callstack()",0);
 }
 
+F_COMPILED *frame_code(F_STACK_FRAME *frame)
+{
+	return (F_COMPILED *)frame->xt - 1;
+}
+
 CELL frame_type(F_STACK_FRAME *frame)
 {
-	return xt_to_compiled(frame->xt)->type;
+	return frame_code(frame)->type;
 }
 
 CELL frame_executing(F_STACK_FRAME *frame)
 {
-	F_COMPILED *compiled = xt_to_compiled(frame->xt);
+	F_COMPILED *compiled = frame_code(frame);
 	CELL code_start = (CELL)(compiled + 1);
 	CELL literal_start = code_start
 		+ compiled->code_length
@@ -199,7 +204,7 @@ DEFINE_PRIMITIVE(set_innermost_stack_frame_quot)
 	REGISTER_UNTAGGED(callstack);
 	REGISTER_UNTAGGED(quot);
 
-	if(quot->compiled == F)
+	if(quot->compiledp == F)
 		jit_compile(quot);
 
 	UNREGISTER_UNTAGGED(quot);

vm/callstack.h

@@ -9,6 +9,7 @@ F_STACK_FRAME *fix_callstack_top(F_STACK_FRAME *top, F_STACK_FRAME *bottom);
 void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator);
 void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator);
 F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame);
+F_COMPILED *frame_code(F_STACK_FRAME *frame);
 CELL frame_executing(F_STACK_FRAME *frame);
 CELL frame_scan(F_STACK_FRAME *frame);
 CELL frame_type(F_STACK_FRAME *frame);

vm/code_gc.c

@@ -279,17 +279,17 @@ void collect_literals(void)
 void mark_sweep_step(F_COMPILED *compiled, CELL code_start,
 	CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end)
 {
-	CELL scan;
+	F_COMPILED **start = (F_COMPILED **)words_start;
+	F_COMPILED **end = (F_COMPILED **)words_end;
+	F_COMPILED **iter = start;
 
-	for(scan = words_start; scan < words_end; scan += CELLS)
+	while(iter < end)
-		recursive_mark((XT)get(scan));
+		recursive_mark(compiled_to_block(*iter++));
 }
 
 /* Mark all XTs and literals referenced from a word XT */
-void recursive_mark(XT xt)
+void recursive_mark(F_BLOCK *block)
 {
-	F_BLOCK *block = xt_to_block(xt);
-
 	/* If already marked, do nothing */
 	switch(block->status)
 	{
@@ -303,7 +303,7 @@ void recursive_mark(XT xt)
 		break;
 	}
 
-	F_COMPILED *compiled = xt_to_compiled(xt);
+	F_COMPILED *compiled = block_to_compiled(block);
 	iterate_code_heap_step(compiled,collect_literals_step);
 
 	switch(compiled->finalized)
@@ -388,8 +388,8 @@ CELL compute_heap_forwarding(F_HEAP *heap)
 
 void forward_xt(XT *xt)
 {
-	F_BLOCK *block = xt_to_block(*xt);
+	/* F_BLOCK *block = xt_to_block(*xt);
-	*xt = block_to_xt(block->forwarding);
+	*xt = block_to_xt(block->forwarding); */
 }
 
 void forward_object_xts(void)
@@ -404,14 +404,14 @@ void forward_object_xts(void)
 		{
 			F_WORD *word = untag_object(obj);
 
-			if(in_code_heap_p((CELL)word->xt))
+			if(word->compiledp != F)
 				forward_xt(&word->xt);
 		}
 		else if(type_of(obj) == QUOTATION_TYPE)
 		{
 			F_QUOTATION *quot = untag_object(obj);
 
-			if(in_code_heap_p((CELL)quot->xt))
+			if(quot->compiledp != F)
 				forward_xt(&quot->xt);
 		}
 	}

vm/code_gc.h

@@ -47,18 +47,6 @@ INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)
 /* compiled code */
 F_HEAP code_heap;
 
-/* The compiled code heap is structured into blocks. */
-typedef struct
-{
-	CELL type; /* this is WORD_TYPE or QUOTATION_TYPE */
-	CELL code_length; /* # bytes */
-	CELL reloc_length; /* # bytes */
-	CELL literals_length; /* # bytes */
-	CELL words_length; /* # bytes */
-	CELL finalized; /* has finalize_code_block() been called on this yet? */
-	CELL padding[2];
-} F_COMPILED;
-
 typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start,
 	CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end);
 
@@ -73,14 +61,9 @@ INLINE void iterate_code_heap_step(F_COMPILED *compiled, CODE_HEAP_ITERATOR iter
 	iter(compiled,code_start,reloc_start,literals_start,words_start,words_end);
 }
 
-INLINE F_BLOCK *xt_to_block(XT xt)
+INLINE F_BLOCK *compiled_to_block(F_COMPILED *compiled)
 {
-	return (F_BLOCK *)((CELL)xt - sizeof(F_BLOCK) - sizeof(F_COMPILED));
+	return (F_BLOCK *)compiled - 1;
-}
-
-INLINE F_COMPILED *xt_to_compiled(XT xt)
-{
-	return (F_COMPILED *)((CELL)xt - sizeof(F_COMPILED));
 }
 
 INLINE F_COMPILED *block_to_compiled(F_BLOCK *block)
@@ -88,11 +71,6 @@ INLINE F_COMPILED *block_to_compiled(F_BLOCK *block)
 	return (F_COMPILED *)(block + 1);
 }
 
-INLINE XT block_to_xt(F_BLOCK *block)
-{
-	return (XT)((CELL)block + sizeof(F_BLOCK) + sizeof(F_COMPILED));
-}
-
 INLINE F_BLOCK *first_block(F_HEAP *heap)
 {
 	return (F_BLOCK *)heap->segment->start;
@@ -107,7 +85,7 @@ void init_code_heap(CELL size);
 bool in_code_heap_p(CELL ptr);
 void iterate_code_heap(CODE_HEAP_ITERATOR iter);
 void collect_literals(void);
-void recursive_mark(XT xt);
+void recursive_mark(F_BLOCK *block);
 void dump_heap(F_HEAP *heap);
 void code_gc(void);
 void compact_code_heap(void);

vm/code_heap.c

@@ -36,6 +36,8 @@ void *get_rel_symbol(F_REL *rel, CELL literals_start)
 		return undefined_symbol;
 }
 
+static CELL xt_offset;
+
 /* Compute an address to store at a relocation */
 INLINE CELL compute_code_rel(F_REL *rel,
 	CELL code_start, CELL literals_start, CELL words_start)
@@ -51,7 +53,8 @@ INLINE CELL compute_code_rel(F_REL *rel,
 	case RT_DISPATCH:
 		return CREF(words_start,REL_ARGUMENT(rel));
 	case RT_XT:
-		return get(CREF(words_start,REL_ARGUMENT(rel)));
+		return get(CREF(words_start,REL_ARGUMENT(rel)))
+			+ sizeof(F_COMPILED) + xt_offset;
 	case RT_LABEL:
 		return code_start + REL_ARGUMENT(rel);
 	default:
@@ -127,6 +130,8 @@ void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value)
 void relocate_code_block(F_COMPILED *relocating, CELL code_start,
 	CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end)
 {
+	xt_offset = (profiling_p() ? 0 : profiler_prologue());
+
 	F_REL *rel = (F_REL *)reloc_start;
 	F_REL *rel_end = (F_REL *)literals_start;
 
@@ -172,12 +177,15 @@ void finalize_code_block(F_COMPILED *relocating, CELL code_start,
 		critical_error("Finalizing a finalized block",(CELL)relocating);
 
 	for(scan = words_start; scan < words_end; scan += CELLS)
-		put(scan,(CELL)(untag_word(get(scan))->xt));
+		put(scan,(CELL)(untag_word(get(scan))->code));
 
 	relocating->finalized = true;
 
+	if(reloc_start != literals_start)
+	{
 		relocate_code_block(relocating,code_start,reloc_start,
 			literals_start,words_start,words_end);
+	}
 
 	flush_icache(code_start,reloc_start - code_start);
 }
@@ -231,7 +239,7 @@ CELL allot_code_block(CELL size)
 	return start;
 }
 
-XT add_compiled_block(
+F_COMPILED *add_compiled_block(
 	CELL type,
 	F_ARRAY *code,
 	F_ARRAY *labels,
@@ -252,7 +260,7 @@ XT add_compiled_block(
 	REGISTER_UNTAGGED(words);
 	REGISTER_UNTAGGED(literals);
 
-	CELL start = allot_code_block(sizeof(F_COMPILED) + code_length
+	CELL here = allot_code_block(sizeof(F_COMPILED) + code_length
 		+ rel_length + literals_length + words_length);
 
 	UNREGISTER_UNTAGGED(literals);
@@ -261,9 +269,6 @@ XT add_compiled_block(
 	UNREGISTER_UNTAGGED(labels);
 	UNREGISTER_UNTAGGED(code);
 
-	/* begin depositing the code block's contents */
-	CELL here = start;
-
 	/* compiled header */
 	F_COMPILED *header = (void *)here;
 	header->type = type;
@@ -275,6 +280,8 @@ XT add_compiled_block(
 
 	here += sizeof(F_COMPILED);
 
+	CELL code_start = here;
+
 	/* code */
 	deposit_integers(here,code,code_format);
 	here += code_length;
@@ -300,18 +307,26 @@ XT add_compiled_block(
 		here += words_length;
 	}
 
-	/* compute the XT */
-	XT xt = (XT)(start + sizeof(F_COMPILED));
-
 	/* fixup labels */
 	if(labels)
-		fixup_labels(labels,code_format,(CELL)xt);
+		fixup_labels(labels,code_format,code_start);
 
 	/* next time we do a minor GC, we have to scan the code heap for
 	literals */
 	last_code_heap_scan = NURSERY;
 
-	return xt;
+	return header;
+}
+
+void set_word_xt(F_WORD *word, F_COMPILED *compiled)
+{
+	word->code = compiled;
+	word->xt = (XT)(compiled + 1);
+
+	if(!profiling_p())
+		word->xt += profiler_prologue();
+
+	word->compiledp = T;
 }
 
 DEFINE_PRIMITIVE(add_compiled_block)
@@ -322,12 +337,11 @@ DEFINE_PRIMITIVE(add_compiled_block)
 	F_ARRAY *words = untag_array(dpop());
 	F_ARRAY *literals = untag_array(dpop());
 
-	XT xt = add_compiled_block(WORD_TYPE,code,labels,rel,words,literals);
+	F_COMPILED *compiled = add_compiled_block(WORD_TYPE,code,labels,rel,words,literals);
 
-	/* push the XT of the new word on the stack */
+	/* push a new word whose XT points to this code block on the stack */
 	F_WORD *word = allot_word(F,F);
-	word->xt = xt;
+	set_word_xt(word,compiled);
-	word->compiledp = T;
 	dpush(tag_object(word));
 }
 
@@ -344,13 +358,8 @@ DEFINE_PRIMITIVE(finalize_compile)
 	{
 		F_ARRAY *pair = untag_array(array_nth(array,i));
 		F_WORD *word = untag_word(array_nth(pair,0));
-		XT xt = untag_word(array_nth(pair,1))->xt;
+		F_COMPILED *compiled = untag_word(array_nth(pair,1))->code;
-		F_BLOCK *block = xt_to_block(xt);
+		set_word_xt(word,compiled);
-		if(block->status != B_ALLOCATED)
-			critical_error("bad XT",(CELL)xt);
-
-		word->xt = xt;
-		word->compiledp = T;
 	}
 
 	/* perform relocation */
@@ -358,7 +367,6 @@ DEFINE_PRIMITIVE(finalize_compile)
 	{
 		F_ARRAY *pair = untag_array(array_nth(array,i));
 		F_WORD *word = untag_word(array_nth(pair,0));
-		XT xt = word->xt;
+		iterate_code_heap_step(word->code,finalize_code_block);
-		iterate_code_heap_step(xt_to_compiled(xt),finalize_code_block);
 	}
 }

vm/code_heap.h

@@ -57,7 +57,9 @@ void relocate_code_block(F_COMPILED *relocating, CELL code_start,
 void finalize_code_block(F_COMPILED *relocating, CELL code_start,
 	CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end);
 
-XT add_compiled_block(
+void set_word_xt(F_WORD *word, F_COMPILED *compiled);
+
+F_COMPILED *add_compiled_block(
 	CELL type,
 	F_ARRAY *code,
 	F_ARRAY *labels,

vm/data_gc.c

@@ -386,7 +386,7 @@ void collect_stack_frame(F_STACK_FRAME *frame)
 	}
 
 	if(collecting_code)
-		recursive_mark(frame->xt);
+		recursive_mark(compiled_to_block(frame_code(frame)));
 }
 
 /* The base parameter allows us to adjust for a heap-allocated
@@ -402,9 +402,6 @@ void collect_callstack(F_CONTEXT *stacks)
 the user environment and extra roots registered with REGISTER_ROOT */
 void collect_roots(void)
 {
-	int i;
-	F_CONTEXT *stacks;
-
 	copy_handle(&T);
 	copy_handle(&bignum_zero);
 	copy_handle(&bignum_pos_one);
@@ -413,7 +410,7 @@ void collect_roots(void)
 	collect_stack(extra_roots_region,extra_roots);
 
 	save_stacks();
-	stacks = stack_chain;
+	F_CONTEXT *stacks = stack_chain;
 
 	while(stacks)
 	{
@@ -428,6 +425,7 @@ void collect_roots(void)
 		stacks = stacks->next;
 	}
 
+	int i;
 	for(i = 0; i < USER_ENV; i++)
 		copy_handle(&userenv[i]);
 }
@@ -517,13 +515,13 @@ CELL binary_payload_start(CELL pointer)
 		return 0;
 	/* these objects have some binary data at the end */
 	case WORD_TYPE:
-		return sizeof(F_WORD) - CELLS;
+		return sizeof(F_WORD) - CELLS * 2;
 	case ALIEN_TYPE:
 		return CELLS * 3;
 	case DLL_TYPE:
 		return CELLS * 2;
 	case QUOTATION_TYPE:
-		return sizeof(F_QUOTATION) - CELLS;
+		return sizeof(F_QUOTATION) - CELLS * 2;
 	/* everything else consists entirely of pointers */
 	default:
 		return unaligned_object_size(pointer);
@@ -549,12 +547,12 @@ CELL collect_next(CELL scan)
 	case WORD_TYPE:
 		word = (F_WORD *)scan;
 		if(collecting_code && word->compiledp != F)
-			recursive_mark(word->xt);
+			recursive_mark(compiled_to_block(word->code));
 		break;
 	case QUOTATION_TYPE:
 		quot = (F_QUOTATION *)scan;
-		if(collecting_code && quot->xt != lazy_jit_compile)
+		if(collecting_code && quot->compiledp != F)
-			recursive_mark(quot->xt);
+			recursive_mark(compiled_to_block(quot->code));
 		break;
 	case CALLSTACK_TYPE:
 		stack = (F_CALLSTACK *)scan;

vm/debug.c

@@ -192,6 +192,7 @@ void dump_generations(void)
 
 void dump_objects(F_FIXNUM type)
 {
+	data_gc();
 	begin_scan();
 
 	CELL obj;

vm/errors.c

@@ -15,6 +15,10 @@ void critical_error(char* msg, CELL tagged)
 
 void throw_error(CELL error, F_STACK_FRAME *callstack_top)
 {
+	/* If the error handler is set, we rewind any C stack frames and
+	pass the error to user-space. */
+	if(userenv[BREAK_ENV] != F)
+	{
 		/* If error was thrown during heap scan, we re-enable the GC */
 		gc_off = false;
 
@@ -27,10 +31,6 @@ void throw_error(CELL error, F_STACK_FRAME *callstack_top)
 
 		dpush(error);
 
-	/* If the error handler is set, we rewind any C stack frames and
-	pass the error to user-space. */
-	if(userenv[BREAK_ENV] != F)
-	{
 		/* Errors thrown from C code pass NULL for this parameter.
 		Errors thrown from Factor code, or signal handlers, pass the
 		actual stack pointer at the time, since the saved pointer is

vm/factor.c

@@ -43,8 +43,6 @@ void init_factor(F_PARAMETERS *p)
 	/* Disable GC during init as a sanity check */
 	gc_off = true;
 
-	profiling = false;
-
 	early_init();
 
 	if(p->image == NULL)

vm/image.c

@@ -144,8 +144,8 @@ DEFINE_PRIMITIVE(save_image_and_exit)
 		userenv[i] = F;
 
 	/* do a full GC + code heap compaction */
-	compact_code_heap();
+	//compact_code_heap();
-
+	code_gc();
 	save_image(unbox_native_string());
 
 	/* now exit; we cannot continue executing like this */
@@ -159,15 +159,21 @@ void fixup_word(F_WORD *word)
 	if(word->compiledp == F)
 		word->xt = default_word_xt(word);
 	else
+	{
 		code_fixup(&word->xt);
+		code_fixup(&word->code);
+	}
 }
 
 void fixup_quotation(F_QUOTATION *quot)
 {
-	if(quot->compiled == F)
+	if(quot->compiledp == F)
 		quot->xt = lazy_jit_compile;
 	else
+	{
 		code_fixup(&quot->xt);
+		code_fixup(&quot->code);
+	}
 }
 
 void fixup_alien(F_ALIEN *d)
@@ -263,8 +269,11 @@ void fixup_code_block(F_COMPILED *relocating, CELL code_start,
 			data_fixup((CELL*)scan);
 	}
 
+	if(reloc_start != literals_start)
+	{
 		relocate_code_block(relocating,code_start,reloc_start,
 			literals_start,words_start,words_end);
+	}
 }
 
 void relocate_code()

vm/layouts.h

@@ -144,6 +144,18 @@ typedef struct {
 	CELL array;
 } F_HASHTABLE;
 
+/* The compiled code heap is structured into blocks. */
+typedef struct
+{
+	CELL type; /* this is WORD_TYPE or QUOTATION_TYPE */
+	CELL code_length; /* # bytes */
+	CELL reloc_length; /* # bytes */
+	CELL literals_length; /* # bytes */
+	CELL words_length; /* # bytes */
+	CELL finalized; /* has finalize_code_block() been called on this yet? */
+	CELL padding[2];
+} F_COMPILED;
+
 /* Assembly code makes assumptions about the layout of this struct */
 typedef struct {
 	/* TAGGED header */
@@ -164,6 +176,8 @@ typedef struct {
 	CELL counter;
 	/* UNTAGGED execution token: jump here to execute word */
 	XT xt;
+	/* UNTAGGED compiled code block */
+	F_COMPILED *code;
 } F_WORD;
 
 /* Assembly code makes assumptions about the layout of this struct */
@@ -195,9 +209,11 @@ typedef struct {
 	/* tagged */
 	CELL array;
 	/* tagged */
-	CELL compiled;
+	CELL compiledp;
-	/* untagged */
+	/* UNTAGGED */
 	XT xt;
+	/* UNTAGGED compiled code block */
+	F_COMPILED *code;
 } F_QUOTATION;
 
 /* Assembly code makes assumptions about the layout of this struct */

vm/master.h

@@ -22,6 +22,7 @@
 #include "primitives.h"
 #include "debug.h"
 #include "run.h"
+#include "profiler.h"
 #include "errors.h"
 #include "bignumint.h"
 #include "bignum.h"

vm/profiler.c

@@ -0,0 +1,60 @@
+#include "master.h"
+
+bool profiling_p(void)
+{
+	return to_boolean(userenv[PROFILING_ENV]);
+}
+
+F_FIXNUM profiler_prologue(void)
+{
+	return to_fixnum(userenv[PROFILER_PROLOGUE_ENV]);
+}
+
+void profiling_word(F_WORD *word)
+{
+	/* If we just enabled the profiler, reset call count */
+	if(profiling_p())
+		word->counter = tag_fixnum(0);
+
+	if(word->compiledp == F)
+	{
+		if(type_of(word->def) == QUOTATION_TYPE)
+			word->xt = default_word_xt(word);
+	}
+	else
+		set_word_xt(word,word->code);
+}
+
+void set_profiling(bool profiling)
+{
+	if(profiling == profiling_p())
+		return;
+
+	userenv[PROFILING_ENV] = tag_boolean(profiling);
+
+	/* Push everything to tenured space so that we can heap scan */
+	data_gc();
+
+	/* Step 1 - Update word XTs and saved callstack objects */
+	begin_scan();
+
+	CELL obj;
+	while((obj = next_object()) != F)
+	{
+		if(type_of(obj) == WORD_TYPE)
+			profiling_word(untag_object(obj));
+	}
+
+	gc_off = false; /* end heap scan */
+
+	/* Step 2 - Update XTs in code heap */
+	iterate_code_heap(relocate_code_block);
+
+	/* Step 3 - flush instruction cache */
+	flush_icache(code_heap.segment->start,code_heap.segment->size);
+}
+
+DEFINE_PRIMITIVE(profiling)
+{
+	set_profiling(to_boolean(dpop()));
+}

vm/profiler.h

@@ -0,0 +1,3 @@
+bool profiling_p(void);
+F_FIXNUM profiler_prologue(void);
+DECLARE_PRIMITIVE(profiling);

vm/quotations.c

@@ -37,6 +37,13 @@ bool jit_stack_frame_p(F_ARRAY *array)
 	return false;
 }
 
+void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code)
+{
+	quot->code = code;
+	quot->xt = (XT)(code + 1);
+	quot->compiledp = T;
+}
+
 void jit_compile(F_QUOTATION *quot)
 {
 	F_ARRAY *array = untag_object(quot->array);
@@ -148,12 +155,11 @@ void jit_compile(F_QUOTATION *quot)
 	F_ARRAY *literals = allot_array(ARRAY_TYPE,1,tag_object(quot));
 	UNREGISTER_UNTAGGED(result);
 
-	XT xt = add_compiled_block(QUOTATION_TYPE,result,NULL,NULL,NULL,literals);
+	F_COMPILED *compiled = add_compiled_block(QUOTATION_TYPE,result,NULL,NULL,NULL,literals);
-	iterate_code_heap_step(xt_to_compiled(xt),finalize_code_block);
+	iterate_code_heap_step(compiled,finalize_code_block);
 
 	UNREGISTER_UNTAGGED(quot);
-	quot->xt = xt;
+	set_quot_xt(quot,compiled);
-	quot->compiled = T;
 }
 
 F_FASTCALL CELL primitive_jit_compile(CELL tagged, F_STACK_FRAME *stack)
@@ -222,7 +228,7 @@ DEFINE_PRIMITIVE(array_to_quotation)
 	F_QUOTATION *quot = allot_object(QUOTATION_TYPE,sizeof(F_QUOTATION));
 	quot->array = dpeek();
 	quot->xt = lazy_jit_compile;
-	quot->compiled = F;
+	quot->compiledp = F;
 	drepl(tag_object(quot));
 }
 
@@ -234,6 +240,7 @@ DEFINE_PRIMITIVE(quotation_xt)
 
 DEFINE_PRIMITIVE(strip_compiled_quotations)
 {
+	data_gc();
 	begin_scan();
 
 	CELL obj;
@@ -242,7 +249,7 @@ DEFINE_PRIMITIVE(strip_compiled_quotations)
 		if(type_of(obj) == QUOTATION_TYPE)
 		{
 			F_QUOTATION *quot = untag_object(obj);
-			quot->compiled = F;
+			quot->compiledp = F;
 			quot->xt = lazy_jit_compile;
 		}
 	}

vm/run.c

@@ -269,7 +269,7 @@ XT default_word_xt(F_WORD *word)
 		return dosym;
 	else if(type_of(word->def) == QUOTATION_TYPE)
 	{
-		if(profiling)
+		if(profiling_p())
 			return docol_profiling;
 		else
 			return docol;
@@ -364,36 +364,3 @@ DEFINE_PRIMITIVE(set_slot)
 	CELL value = dpop();
 	set_slot(obj,slot,value);
 }
-
-void enable_word_profiling(F_WORD *word)
-{
-	if(word->xt == docol)
-		word->xt = docol_profiling;
-}
-
-void disable_word_profiling(F_WORD *word)
-{
-	if(word->xt == docol_profiling)
-		word->xt = docol;
-}
-
-DEFINE_PRIMITIVE(profiling)
-{
-	profiling = to_boolean(dpop());
-
-	begin_scan();
-
-	CELL obj;
-	while((obj = next_object()) != F)
-	{
-		if(type_of(obj) == WORD_TYPE)
-		{
-			if(profiling)
-				enable_word_profiling(untag_object(obj));
-			else
-				disable_word_profiling(untag_object(obj));
-		}
-	}
-
-	gc_off = false; /* end heap scan */
-}

vm/run.h

@@ -1,6 +1,3 @@
-/* Is profiling on? */
-DLLEXPORT bool profiling;
-
 #define USER_ENV 40
 
 typedef enum {
@@ -52,6 +49,10 @@ typedef enum {
 	JIT_DISPATCH,
 	JIT_EPILOG,
 	JIT_RETURN,
+
+	/* Profiler support */    
+	PROFILING_ENV       = 38, /* is the profiler on? */
+	PROFILER_PROLOGUE_ENV     /* length of optimizing compiler's profiler prologue */
 } F_ENVTYPE;
 
 #define FIRST_SAVE_ENV BOOT_ENV
@@ -242,4 +243,3 @@ DECLARE_PRIMITIVE(tag);
 DECLARE_PRIMITIVE(class_hash);
 DECLARE_PRIMITIVE(slot);
 DECLARE_PRIMITIVE(set_slot);
-DECLARE_PRIMITIVE(profiling);