diff --git a/core/compiler/batch/batch.factor b/core/compiler/batch/batch.factor old mode 100644 new mode 100755 index 3c725bbc9a..13d0295e9e --- a/core/compiler/batch/batch.factor +++ b/core/compiler/batch/batch.factor @@ -5,50 +5,46 @@ optimizer arrays definitions sequences assocs continuations generator compiler ; IN: compiler.batch -! SYMBOL: compile-queue -! SYMBOL: compile-results -! -! TUPLE: compiled literals words rel labels code ; -! -! C: compiled -! -! : queue-compile ( word -- ) -! compile-queue get push-front ; -! -! : word-dataflow ( word -- effect dataflow ) -! [ -! dup "no-effect" word-prop [ no-effect ] when -! dup specialized-def over dup 2array 1array infer-quot -! finish-word -! ] with-infer ; -! -! : compiled-usage usage [ word? ] subset ; -! -! : ripple-up ( effect word -- ) -! tuck "compiled-effect" word-prop = -! [ drop ] [ compiled-usage [ queue-compile ] each ] if ; -! -! : save-effect ( effect word -- ) -! swap "compiled-effect" set-word-prop ; -! -! : add-compiled ( word -- ) -! >r f f f f f r> compile-results get set-at ; -! -! : compile-1 ( word -- ) -! dup compile-results get at [ drop ] [ -! [ [ word-dataflow drop ] [ 2drop f ] recover ] keep -! 2dup ripple-up -! tuck save-effect -! add-compiled -! ] if ; -! -! : compile-batch ( words -- ) -! [ -! compile-queue set -! [ queue-compile ] each -! H{ } clone compile-results set -! compile-queue get [ compile-1 ] dlist-slurp -! compile-results get -! ] with-scope ; +: with-compilation-unit ( quot -- ) + H{ } clone + [ compiled-xts swap with-variable ] keep + [ swap add* ] { } assoc>map modify-code-heap ; +: compile-batch ( words -- ) + [ [ (compile) ] curry [ print-error ] recover ] each ; +SYMBOL: compile-queue + +: queue-compile ( word -- ) + compile-queue get push-front ; + +: compiled-usage ( word -- seq ) + #! XXX + usage [ word? ] subset ; + +: ripple-up ( effect word -- ) + tuck "compiled-effect" word-prop = + [ drop ] [ compiled-usage [ queue-compile ] each ] if ; + +: save-effect ( effect word -- ) + swap "compiled-effect" set-word-prop ; + +: add-compiled ( word -- ) + >r f f f f f r> compile-results get set-at ; + +: compile-1 ( word -- ) + dup compile-results get at [ drop ] [ + [ [ word-dataflow drop ] [ 2drop f ] recover ] keep + 2dup ripple-up + tuck save-effect + add-compiled + ] if ; + +: compile-batch ( words -- ) + [ + compile-queue set + [ queue-compile ] each + H{ } clone compile-results set + compile-queue get [ compile-1 ] dlist-slurp + compile-results get + ] with-scope ; diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 4d6529fc7f..2c39b7f0e2 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -2,23 +2,49 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces arrays sequences io inference.backend generator debugger math.parser prettyprint words continuations -vocabs assocs alien.compiler ; +vocabs assocs alien.compiler dlists optimizer ; IN: compiler +SYMBOL: compiler-hook + +: compile-begins ( word -- ) + compiler-hook get [ call ] when* + "quiet" get [ drop ] [ "Compiling " write . flush ] if ; + +: (compile) ( word -- ) + dup compiling? not over compound? and [ + [ + dup compile-begins + dup dup word-dataflow nip optimize generate + ] curry [ print-error ] recover + ] [ drop ] if ; + +: finish-compilation-unit ( assoc -- ) + [ swap add* ] { } assoc>map modify-code-heap ; + +: with-compilation-unit ( quot -- ) + [ + compile-queue set + H{ } clone compiled-xts set + call + compile-queue get [ (compile) ] dlist-slurp + compiled-xts get finish-compilation-unit + ] with-scope ; inline + : compile-batch ( words -- ) - H{ } clone [ - compiled-xts [ - [ [ (compile) ] curry [ print-error ] recover ] each - ] with-variable - ] keep [ swap add* ] { } assoc>map modify-code-heap ; + [ [ queue-compile ] each ] with-compilation-unit ; -: compile ( word -- ) 1array compile-batch ; +: compile ( word -- ) + [ queue-compile ] with-compilation-unit ; -: compile-vocabs ( seq -- ) [ words ] map concat compile-batch ; +: compile-vocabs ( seq -- ) + [ words ] map concat compile-batch ; -: compile-quot ( quot -- word ) define-temp dup compile ; +: compile-quot ( quot -- word ) + define-temp dup compile ; -: compile-1 ( quot -- ) compile-quot execute ; +: compile-1 ( quot -- ) + compile-quot execute ; : recompile ( -- ) changed-words get [ diff --git a/core/generator/generator-docs.factor b/core/generator/generator-docs.factor old mode 100644 new mode 100755 index 42121759c3..b5e3ef0f24 --- a/core/generator/generator-docs.factor +++ b/core/generator/generator-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax words debugger generator.fixup -generator.registers quotations kernel vectors arrays ; +generator.registers quotations kernel vectors arrays effects ; IN: generator ARTICLE: "generator" "Compiled code generator" @@ -64,7 +64,7 @@ HELP: generate { $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." } ; HELP: word-dataflow -{ $values { "word" word } { "dataflow" "a dataflow graph" } } +{ $values { "word" word } { "effect" effect } { "dataflow" "a dataflow graph" } } { $description "Outputs the dataflow graph of a word, taking specializers into account (see " { $link "specializers" } ")." } ; HELP: define-intrinsics diff --git a/core/generator/generator.factor b/core/generator/generator.factor index b2868b5a96..aebc359bb9 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -4,13 +4,20 @@ USING: arrays assocs classes combinators cpu.architecture effects generator.fixup generator.registers generic hashtables inference inference.backend inference.dataflow io kernel kernel.private layouts math namespaces optimizer prettyprint -quotations sequences system threads words ; +quotations sequences system threads words dlists ; IN: generator +SYMBOL: compile-queue + SYMBOL: compiled-xts -: save-xt ( word xt -- ) - swap dup unchanged-word compiled-xts get set-at ; +: 6array 3array >r 3array r> append ; + +: begin-compiling ( word -- ) + f swap compiled-xts get set-at ; + +: finish-compiling ( word literals words rel labels code -- ) + 6array swap dup unchanged-word compiled-xts get set-at ; : compiling? ( word -- ? ) { @@ -19,6 +26,9 @@ SYMBOL: compiled-xts { [ t ] [ compiled? ] } } cond ; +: queue-compile ( word -- ) + compile-queue get push-front ; + SYMBOL: compiling-word SYMBOL: compiling-label @@ -36,17 +46,15 @@ t compiled-stack-traces? set-global compiled-stack-traces? get compiling-word get f ? literal-table get push ; -: 6array 3array >r 3array r> append ; - : generate-1 ( word label node quot -- ) - pick f save-xt [ + pick begin-compiling [ roll compiling-word set pick compiling-label set init-generator call literal-table get >array word-table get >array - ] { } make fixup 6array save-xt ; + ] { } make fixup finish-compiling ; : generate-profiler-prologue ( -- ) compiled-stack-traces? get [ @@ -70,30 +78,12 @@ GENERIC: generate-node ( node -- next ) profiler-prologue get ] generate-1 ; -: word-dataflow ( word -- dataflow ) +: word-dataflow ( word -- effect dataflow ) [ dup "no-effect" word-prop [ no-effect ] when dup specialized-def over dup 2array 1array infer-quot finish-word - ] with-infer nip ; - -SYMBOL: compiler-hook - -[ ] compiler-hook set-global - -SYMBOL: compile-errors - -: compile-begins ( word -- ) - compiler-hook get call - "quiet" get [ drop ] [ "Compiling " write . flush ] if ; - -: (compile) ( word -- ) - dup compiling? not over compound? and [ - dup compile-begins - dup dup word-dataflow optimize generate - ] [ - drop - ] if ; + ] with-infer ; : intrinsics ( #call -- quot ) node-param "intrinsics" word-prop ; @@ -140,7 +130,7 @@ M: node generate-node drop iterate-next ; } cond ; : generate-call ( label -- next ) - dup (compile) + dup queue-compile end-basic-block tail-call? [ %jump f diff --git a/core/listener/listener.factor b/core/listener/listener.factor index 6ff8d6a4af..f0ded202b0 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -48,7 +48,7 @@ M: duplex-stream parse-interactive listener-hook get call prompt. [ stdio get parse-interactive - [ do-parse-hook call ] [ bye ] if* + [ call ] [ bye ] if* ] try ; : until-quit ( -- ) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 441eaca9cf..8d1b488822 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -443,8 +443,8 @@ SYMBOL: parse-hook \ contents get string-lines parse-fresh dup finish-parsing do-parse-hook - ] with-scope - ] [ ] [ undo-parsing ] cleanup ; + ] [ ] [ undo-parsing ] cleanup + ] with-scope ; : parse-file-restarts ( file -- restarts ) "Load " swap " again" 3append t 2array 1array ; diff --git a/vm/code_heap.c b/vm/code_heap.c index 8f79078862..049274af8a 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -38,6 +38,11 @@ void *get_rel_symbol(F_REL *rel, CELL literals_start) static CELL xt_offset; +void incompatible_call_error(void) +{ + critical_error("Calling non-optimized word from optimized word",0); +} + /* 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) @@ -56,10 +61,16 @@ INLINE CELL compute_code_rel(F_REL *rel, return CREF(words_start,REL_ARGUMENT(rel)); case RT_XT: word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel)))); - return (CELL)word->code + sizeof(F_COMPILED) + xt_offset; + if(word->compiledp == F) + return (CELL)incompatible_call_error; + else + return (CELL)word->code + sizeof(F_COMPILED) + xt_offset; case RT_XT_PROFILING: word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel)))); - return (CELL)word->code + sizeof(F_COMPILED); + if(word->compiledp == F) + return (CELL)incompatible_call_error; + else + return (CELL)word->code + sizeof(F_COMPILED); case RT_LABEL: return code_start + REL_ARGUMENT(rel); default: @@ -365,5 +376,6 @@ DEFINE_PRIMITIVE(modify_code_heap) set_word_xt(word,compiled); } - iterate_code_heap(finalize_code_block); + if(count != 0) + iterate_code_heap(finalize_code_block); }