diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index a3fc5b5534..9728d4298a 100755 --- a/core/alien/compiler/compiler.factor +++ b/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 diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index eb65e7182b..17e03c768f 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -1,16 +1,17 @@ -USING: compiler vocabs.loader system sequences namespaces -parser kernel kernel.private classes classes.private +USING: compiler cpu.architecture vocabs.loader system sequences +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 -words generator command-line vocabs io prettyprint libc ; +growable namespaces.private alien.remote-control assocs words +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 diff --git a/core/cpu/arm/architecture/architecture.factor b/core/cpu/arm/architecture/architecture.factor index 5fdca75f98..07a4a073de 100755 --- a/core/cpu/arm/architecture/architecture.factor +++ b/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 diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index 714b41453b..9dd6c9c6c8 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/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" } } } diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index e35c4a3d52..0ff85d637b 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/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 ; diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index b45f463bbe..8730258d6d 100644 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -64,12 +64,13 @@ SYMBOL: label-table rot rc-absolute-ppc-2/2 = or or ; ! Relocation types -: rt-primitive 0 ; -: rt-dlsym 1 ; -: rt-literal 2 ; -: rt-dispatch 3 ; -: rt-xt 4 ; -: rt-label 5 ; +: rt-primitive 0 ; +: rt-dlsym 1 ; +: rt-literal 2 ; +: rt-dispatch 3 ; +: rt-xt 4 ; +: rt-xt-profiling 5 ; +: rt-label 6 ; TUPLE: label-fixup label class ; diff --git a/core/generator/generator-docs.factor b/core/generator/generator-docs.factor index 43089ca91a..a68454f001 100644 --- a/core/generator/generator-docs.factor +++ b/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 } } diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 9e2cc23765..77f45dc70d 100755 --- a/core/generator/generator.factor +++ b/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 - ] map "intrinsics" set-word-prop ; + ] assoc-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 ; diff --git a/core/math/math.factor b/core/math/math.factor index fea77855eb..54651f51d8 100755 --- a/core/math/math.factor +++ b/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 <=> - ; diff --git a/extra/tools/profiler/profiler-docs.factor b/extra/tools/profiler/profiler-docs.factor index 0c06417c1c..feb6abbbb1 100644 --- a/extra/tools/profiler/profiler-docs.factor +++ b/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." } ; diff --git a/extra/tools/profiler/profiler.factor b/extra/tools/profiler/profiler.factor index 456c4876ec..4702431a8f 100755 --- a/extra/tools/profiler/profiler.factor +++ b/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 -- ) diff --git a/vm/code_gc.c b/vm/code_gc.c index aa97203444..3d74ae0e4c 100644 --- a/vm/code_gc.c +++ b/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); - *xt = block_to_xt(block->forwarding); */ + return block_to_compiled(compiled_to_block(compiled)->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("->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; - XT *end = (XT *)words_end; + F_COMPILED **iter = (F_COMPILED **)words_start; + F_COMPILED **end = (F_COMPILED **)words_end; while(iter < end) - forward_xt(iter++); + { + *iter = forward_xt(*iter); + iter++; + } } void forward_block_xts(void) diff --git a/vm/code_heap.c b/vm/code_heap.c index 6e6d024147..ccf2c99a38 100644 --- a/vm/code_heap.c +++ b/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: diff --git a/vm/code_heap.h b/vm/code_heap.h index 4bc6803533..45312fca02 100644 --- a/vm/code_heap.h +++ b/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; diff --git a/vm/image.c b/vm/image.c index bca8a36052..e1398eed81 100755 --- a/vm/image.c +++ b/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(); - code_gc(); + compact_code_heap(); + + /* 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(&word->code); + code_fixup((CELL)&word->xt); + code_fixup((CELL)&word->code); } } @@ -171,8 +172,8 @@ void fixup_quotation(F_QUOTATION *quot) quot->xt = lazy_jit_compile; else { - code_fixup("->xt); - code_fixup("->code); + code_fixup((CELL)"->xt); + code_fixup((CELL)"->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); } diff --git a/vm/image.h b/vm/image.h index 0fc2f03a3d..52b666254e 100755 --- a/vm/image.h +++ b/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; - value += (code_heap.segment->start - code_relocation_base); - *cell = (XT)value; + CELL value = get(cell); + put(cell,value + (code_heap.segment->start - code_relocation_base)); } void relocate_data(); diff --git a/vm/quotations.h b/vm/quotations.h index d70d37ac44..e8da6093cd 100644 --- a/vm/quotations.h +++ b/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);