Profiler fixes

core/alien/compiler/compiler.factor

@@ -383,10 +383,11 @@ TUPLE: callback-context ;
 
 : generate-callback ( node -- )
     dup alien-callback-xt dup rot [
+        init-templates
+        generate-profiler-prologue
         %save-xt
         %prologue-later
         dup alien-stack-frame [
-            init-templates
             dup registers>objects
             dup wrap-callback-quot %alien-callback
             %callback-return

core/bootstrap/compiler/compiler.factor

@@ -1,16 +1,17 @@
-USING: compiler vocabs.loader system sequences namespaces
+USING: compiler cpu.architecture vocabs.loader system sequences
-parser kernel kernel.private classes classes.private
+namespaces parser kernel kernel.private classes classes.private
 arrays hashtables vectors tuples sbufs inference.dataflow
 hashtables.private sequences.private math tuples.private
-growable namespaces.private alien.remote-control assocs
+growable namespaces.private alien.remote-control assocs words
-words generator command-line vocabs io prettyprint libc ;
+generator command-line vocabs io prettyprint libc ;
 
 "cpu." cpu append require
 
 global [ { "compiler" } add-use ] bind
 
 "-no-stack-traces" cli-args member? [
-    f compiled-stack-traces set-global
+    f compiled-stack-traces? set-global
+    0 set-profiler-prologues
 ] when
 
 ! Compile a set of words ahead of our general

core/cpu/arm/architecture/architecture.factor

@@ -67,7 +67,7 @@ M: arm-backend stack-frame ( n -- i )
     factor-area-size + 8 align ;
 
 M: arm-backend %save-xt ( -- )
-    R12 PC 8 SUB ;
+    R12 PC 9 cells SUB ;
 
 M: arm-backend %prologue ( n -- )
     SP SP pick SUB

core/cpu/ppc/architecture/architecture.factor

@@ -76,11 +76,8 @@ M: ppc-backend load-indirect ( obj reg -- )
     [ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
     dup 0 LWZ ;
 
-: %load-xt ( word reg -- )
-    0 swap LOAD32  rc-absolute-ppc-2/2 rel-word ;
-
 M: ppc-backend %save-xt ( -- )
-    compiling-label get 11 %load-xt ;
+    0 11 LOAD32 rc-absolute-ppc-2/2 rel-current-word ;
 
 M: ppc-backend %prologue ( n -- )
     0 MFLR
@@ -114,7 +111,9 @@ M: ppc-backend %jump-label ( label -- ) B ;
 
 : %prepare-primitive ( word -- )
     #! Save stack pointer to stack_chain->callstack_top, load XT
-    4 1 MR 11 %load-xt ;
+    4 1 MR
+    0 11 LOAD32
+    rc-absolute-ppc-2/2 rel-word ;
 
 : (%call) 11 MTLR BLRL ;
 
@@ -135,6 +134,7 @@ M: ppc-backend %jump-t ( label -- )
         "offset" operand "n" operand 1 SRAWI
         0 11 LOAD32 rc-absolute-ppc-2/2 rel-dispatch
         11 dup "offset" operand LWZX
+        11 dup compiled-header-size ADDI
         r> call
     ] H{
         { +input+ { { f "n" } } }

core/cpu/x86/architecture/architecture.factor

@@ -45,7 +45,7 @@ M: x86-backend stack-frame ( n -- i )
     3 cells + 16 align cell - ;
 
 M: x86-backend %save-xt ( -- )
-    xt-reg compiling-label get MOV ;
+    xt-reg 0 MOV rc-absolute-cell rel-current-word ;
 
 : factor-area-size 4 cells ;
 

core/generator/fixup/fixup.factor

@@ -69,7 +69,8 @@ SYMBOL: label-table
 : rt-literal      2 ;
 : rt-dispatch     3 ;
 : rt-xt           4 ;
-: rt-label     5 ;
+: rt-xt-profiling 5 ;
+: rt-label        6 ;
 
 TUPLE: label-fixup label class ;
 

core/generator/generator-docs.factor

@@ -6,7 +6,7 @@ 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; this hook is used by " { $link "tools.deploy" } ":"
-{ $subsection compiled-stack-traces }
+{ $subsection compiled-stack-traces? }
 "Assembler intrinsics can be defined for low-level optimization:"
 { $subsection define-intrinsic }
 { $subsection define-intrinsics }
@@ -41,11 +41,11 @@ HELP: compiling-word
 HELP: compiling-label
 { $var-description "The label currently being compiled, set by " { $link generate-1 } "." } ;
 
-HELP: compiled-stack-traces
+HELP: compiled-stack-traces?
 { $var-description "If set to true, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This variable is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
 
 HELP: literal-table
-{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces } " is on, " { $link init-generator } " ensures that the first entry is the word being compiled." } ;
+{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link init-generator } " ensures that the first entry is the word being compiled." } ;
 
 HELP: init-generator
 { $values { "word" word } }

core/generator/generator.factor

@@ -26,19 +26,16 @@ SYMBOL: compiling-label
 ! Label of current word, after prologue, makes recursion faster
 SYMBOL: current-label-start
 
-SYMBOL: compiled-stack-traces
+SYMBOL: compiled-stack-traces?
 
-t compiled-stack-traces set-global
+t compiled-stack-traces? set-global
 
 : init-generator ( -- )
     V{ } clone literal-table set
     V{ } clone word-table set
-    compiled-stack-traces get compiling-word get f ?
+    compiled-stack-traces? get compiling-word get f ?
     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
@@ -49,6 +46,11 @@ t compiled-stack-traces set-global
         word-table get >array
     ] { } make fixup add-compiled-block save-xt ;
 
+: generate-profiler-prologue ( -- )
+    compiled-stack-traces? get [
+        compiling-word get %profiler-prologue
+    ] when ;
+
 GENERIC: generate-node ( node -- next )
 
 : generate-nodes ( node -- )
@@ -57,7 +59,7 @@ GENERIC: generate-node ( node -- next )
 : generate ( word label node -- )
     [
         init-templates
-        profiler-prologue
+        generate-profiler-prologue
         %save-xt
         %prologue-later
         current-label-start define-label
@@ -178,6 +180,10 @@ M: #if generate-node
     with-template
     generate-if ;
 
+: rel-current-word ( class -- )
+    compiling-label get add-word
+    swap rt-xt-profiling rel-fixup ;
+
 ! #dispatch
 : dispatch-branch ( node word -- label )
     gensym [
@@ -229,11 +235,9 @@ M: #dispatch generate-node
 
 : define-if>boolean-intrinsics ( word intrinsics -- )
     [
-        first2
         >r [ if>boolean-intrinsic ] curry r>
         { { f "if-scratch" } } +scratch+ associate union
-        2array
+    ] assoc-map "intrinsics" set-word-prop ;
-    ] map "intrinsics" set-word-prop ;
 
 : define-if-intrinsics ( word intrinsics -- )
     [ +input+ associate ] assoc-map
@@ -310,3 +314,4 @@ M: #return generate-node drop end-basic-block %return f ;
 : tuple-class-offset 2 cells tuple tag-number - ;
 : class-hash-offset cell object tag-number - ;
 : word-xt-offset 8 cells object tag-number - ;
+: compiled-header-size 8 cells ;

core/math/math.factor

@@ -91,8 +91,6 @@ M: real hashcode* nip >fixnum ;
 M: real <=> - ;
 
 ! real and sequence overlap. we disambiguate:
-M: integer equal? number= ;
-
 M: integer hashcode* nip >fixnum ;
 
 M: integer <=> - ;

extra/tools/profiler/profiler-docs.factor

@@ -19,10 +19,6 @@ ARTICLE: "profiling" "Profiling code"
 
 ABOUT: "profiling"
 
-HELP: reset-counters
-{ $description "Reset the call count of all words in the dictionary." }
-{ $notes "This word is automatically called by the profiler when profiling begins." } ;
-
 HELP: counters
 { $values { "words" "a sequence of words" } { "assoc" "an association list mapping words to integers" } }
 { $description "Outputs an association list of word call counts." } ;

extra/tools/profiler/profiler.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: words sequences math prettyprint kernel arrays io
 io.styles namespaces assocs kernel.private strings combinators
-sorting math.parser vocabs definitions tools.profiler.private ;
+sorting math.parser vocabs definitions tools.profiler.private
+continuations ;
 IN: tools.profiler
 
 : profile ( quot -- )

vm/code_gc.c

@@ -386,10 +386,9 @@ CELL compute_heap_forwarding(F_HEAP *heap)
 	return address - heap->segment->start;
 }
 
-void forward_xt(XT *xt)
+F_COMPILED *forward_xt(F_COMPILED *compiled)
 {
-	/* F_BLOCK *block = xt_to_block(*xt);
+	return block_to_compiled(compiled_to_block(compiled)->forwarding);
-	*xt = block_to_xt(block->forwarding); */
 }
 
 void forward_object_xts(void)
@@ -405,14 +404,14 @@ void forward_object_xts(void)
 			F_WORD *word = untag_object(obj);
 
 			if(word->compiledp != F)
-				forward_xt(&word->xt);
+				set_word_xt(word,forward_xt(word->code));
 		}
 		else if(type_of(obj) == QUOTATION_TYPE)
 		{
 			F_QUOTATION *quot = untag_object(obj);
 
 			if(quot->compiledp != F)
-				forward_xt(&quot->xt);
+				set_quot_xt(quot,forward_xt(quot->code));
 		}
 	}
 
@@ -423,11 +422,14 @@ void forward_object_xts(void)
 void compaction_code_block_fixup(F_COMPILED *compiled, CELL code_start,
 	CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end)
 {
-	XT *iter = (XT *)words_start;
+	F_COMPILED **iter = (F_COMPILED **)words_start;
-	XT *end = (XT *)words_end;
+	F_COMPILED **end = (F_COMPILED **)words_end;
 
 	while(iter < end)
-		forward_xt(iter++);
+	{
+		*iter = forward_xt(*iter);
+		iter++;
+	}
 }
 
 void forward_block_xts(void)

vm/code_heap.c

@@ -55,6 +55,9 @@ INLINE CELL compute_code_rel(F_REL *rel,
 	case RT_XT:
 		return get(CREF(words_start,REL_ARGUMENT(rel)))
 			+ sizeof(F_COMPILED) + xt_offset;
+	case RT_XT_PROFILING:
+		return get(CREF(words_start,REL_ARGUMENT(rel)))
+			+ sizeof(F_COMPILED);
 	case RT_LABEL:
 		return code_start + REL_ARGUMENT(rel);
 	default:

vm/code_heap.h

@@ -9,6 +9,8 @@ typedef enum {
 	RT_DISPATCH,
 	/* a compiled word reference */
 	RT_XT,
+	/* a compiled word reference, pointing at the profiling prologue */
+	RT_XT_PROFILING,
 	/* a local label */
 	RT_LABEL
 } F_RELTYPE;

vm/image.c

@@ -144,8 +144,9 @@ 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 the image */
 	save_image(unbox_native_string());
 
 	/* now exit; we cannot continue executing like this */
@@ -160,8 +161,8 @@ void fixup_word(F_WORD *word)
 		word->xt = default_word_xt(word);
 	else
 	{
-		code_fixup(&word->xt);
+		code_fixup((CELL)&word->xt);
-		code_fixup(&word->code);
+		code_fixup((CELL)&word->code);
 	}
 }
 
@@ -171,8 +172,8 @@ void fixup_quotation(F_QUOTATION *quot)
 		quot->xt = lazy_jit_compile;
 	else
 	{
-		code_fixup(&quot->xt);
+		code_fixup((CELL)&quot->xt);
-		code_fixup(&quot->code);
+		code_fixup((CELL)&quot->code);
 	}
 }
 
@@ -183,7 +184,7 @@ void fixup_alien(F_ALIEN *d)
 
 void fixup_stack_frame(F_STACK_FRAME *frame)
 {
-	code_fixup(&frame->xt);
+	code_fixup((CELL)&frame->xt);
 
 	if(frame_type(frame) == QUOTATION_TYPE)
 	{
@@ -192,7 +193,7 @@ void fixup_stack_frame(F_STACK_FRAME *frame)
 		frame->scan = scan + frame->array;
 	}
 
-	code_fixup(&FRAME_RETURN_ADDRESS(frame));
+	code_fixup((CELL)&FRAME_RETURN_ADDRESS(frame));
 }
 
 void fixup_callstack_object(F_CALLSTACK *stack)
@@ -264,7 +265,7 @@ void fixup_code_block(F_COMPILED *relocating, CELL code_start,
 	for(scan = words_start; scan < words_end; scan += CELLS)
 	{
 		if(relocating->finalized)
-			code_fixup((XT*)scan);
+			code_fixup(scan);
 		else
 			data_fixup((CELL*)scan);
 	}

vm/image.h

@@ -55,11 +55,10 @@ INLINE void data_fixup(CELL *cell)
 
 CELL code_relocation_base;
 
-INLINE void code_fixup(XT *cell)
+INLINE void code_fixup(CELL cell)
 {
-	CELL value = (CELL)*cell;
+	CELL value = get(cell);
-	value += (code_heap.segment->start - code_relocation_base);
+	put(cell,value + (code_heap.segment->start - code_relocation_base));
-	*cell = (XT)value;
 }
 
 void relocate_data();

vm/quotations.h

@@ -1,3 +1,4 @@
+void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code);
 void jit_compile(F_QUOTATION *quot);
 F_FASTCALL CELL primitive_jit_compile(CELL tagged, F_STACK_FRAME *stack);
 XT quot_offset_to_pc(F_QUOTATION *quot, F_FIXNUM offset);