diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 177632e49e..014586d71c 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -54,4 +54,4 @@ generator command-line vocabs io prettyprint libc ; malloc free memcpy } compile -[ compile-batch ] recompile-hook set-global +[ compile ] recompile-hook set-global diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index b26899b080..35f8283c42 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -29,27 +29,34 @@ SYMBOL: compiler-hook "compiled-effect" set-word-prop ; : (compile) ( word -- ) - dup compiling? not over compound? and [ - [ - dup compile-begins - dup word-dataflow optimize >r over dup r> generate - ] [ - print-error f - ] recover - 2dup ripple-up save-effect - ] [ drop ] if ; + [ + dup compile-begins + dup word-dataflow optimize >r over dup r> generate + ] [ + print-error f + ] recover + 2dup ripple-up save-effect ; + +: delete-any ( assoc -- element ) + [ [ 2drop t ] assoc-find 2drop dup ] keep delete-at ; + +: compile-loop ( assoc -- ) + dup assoc-empty? + [ drop ] [ dup delete-any (compile) compile-loop ] if ; : compile ( words -- ) [ - compile-queue set - H{ } clone compiled-xts set + H{ } clone compile-queue set + H{ } clone compiled set [ queue-compile ] each - compile-queue get [ (compile) ] dlist-slurp - compiled-xts get >alist modify-code-heap + compile-queue get compile-loop + compiled get >alist modify-code-heap ] with-scope ; inline : compile-quot ( quot -- word ) - [ define-temp ] with-compilation-unit ; + H{ } clone changed-words [ + define-temp dup 1array compile + ] with-variable ; : compile-call ( quot -- ) compile-quot execute ; diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index 195e4e9cd5..21d1bfe87a 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -3,3 +3,49 @@ namespaces parser tools.test words kernel sequences arrays io effects tools.test.inference ; IN: temporary +DEFER: b +DEFER: c + +[ ] [ "IN: temporary : a 1 2 ; : b a a ;" eval ] unit-test + +[ 1 2 1 2 ] [ "USE: temporary b" eval ] unit-test + +{ 0 4 } [ b ] unit-test-effect + +[ ] [ "IN: temporary : a 1 2 3 ;" eval ] unit-test + +[ 1 2 3 1 2 3 ] [ "USE: temporary b" eval ] unit-test + +{ 0 6 } [ b ] unit-test-effect + +\ b word-xt "b-xt" set + +[ ] [ "IN: temporary : c b ;" eval ] unit-test + +[ t ] [ "b-xt" get \ b word-xt = ] unit-test + +\ c word-xt "c-xt" set + +[ ] [ "IN: temporary : a 1 2 4 ;" eval ] unit-test + +[ t ] [ "c-xt" get \ c word-xt = ] unit-test + +[ 1 2 4 1 2 4 ] [ "USE: temporary c" eval ] unit-test + +[ ] [ "IN: temporary : a 1 2 ;" eval ] unit-test + +{ 0 4 } [ c ] unit-test-effect + +[ f ] [ "c-xt" get \ c word-xt = ] unit-test + +[ 1 2 1 2 ] [ "USE: temporary c" eval ] unit-test + +[ ] [ "IN: temporary : d 3 ; inline" eval ] unit-test + +[ ] [ "IN: temporary : e d d ;" eval ] unit-test + +[ 3 3 ] [ "USE: temporary e" eval ] unit-test + +[ ] [ "IN: temporary : d 4 ; inline" eval ] unit-test + +[ 4 4 ] [ "USE: temporary e" eval ] unit-test diff --git a/core/compiler/test/simple.factor b/core/compiler/test/simple.factor old mode 100644 new mode 100755 index cc446dee23..5dc07a4818 --- a/core/compiler/test/simple.factor +++ b/core/compiler/test/simple.factor @@ -3,61 +3,59 @@ combinators.private ; IN: temporary ! Test empty word -[ ] [ [ ] compile-1 ] unit-test +[ ] [ [ ] compile-call ] unit-test ! Test literals -[ 1 ] [ [ 1 ] compile-1 ] unit-test -[ 31 ] [ [ 31 ] compile-1 ] unit-test -[ 255 ] [ [ 255 ] compile-1 ] unit-test -[ -1 ] [ [ -1 ] compile-1 ] unit-test -[ 65536 ] [ [ 65536 ] compile-1 ] unit-test -[ -65536 ] [ [ -65536 ] compile-1 ] unit-test -[ "hey" ] [ [ "hey" ] compile-1 ] unit-test +[ 1 ] [ [ 1 ] compile-call ] unit-test +[ 31 ] [ [ 31 ] compile-call ] unit-test +[ 255 ] [ [ 255 ] compile-call ] unit-test +[ -1 ] [ [ -1 ] compile-call ] unit-test +[ 65536 ] [ [ 65536 ] compile-call ] unit-test +[ -65536 ] [ [ -65536 ] compile-call ] unit-test +[ "hey" ] [ [ "hey" ] compile-call ] unit-test ! Calls : no-op ; -[ ] [ [ no-op ] compile-1 ] unit-test -[ 3 ] [ [ no-op 3 ] compile-1 ] unit-test -[ 3 ] [ [ 3 no-op ] compile-1 ] unit-test +[ ] [ [ no-op ] compile-call ] unit-test +[ 3 ] [ [ no-op 3 ] compile-call ] unit-test +[ 3 ] [ [ 3 no-op ] compile-call ] unit-test : bar 4 ; -[ 4 ] [ [ bar no-op ] compile-1 ] unit-test -[ 4 3 ] [ [ no-op bar 3 ] compile-1 ] unit-test -[ 3 4 ] [ [ 3 no-op bar ] compile-1 ] unit-test +[ 4 ] [ [ bar no-op ] compile-call ] unit-test +[ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test +[ 3 4 ] [ [ 3 no-op bar ] compile-call ] unit-test [ ] [ no-op ] unit-test ! Conditionals -[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-1 ] unit-test -[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-1 ] unit-test -[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-1 ] unit-test -[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-1 ] unit-test +[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test +[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test -[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-1 ] unit-test -[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-1 ] unit-test +[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test +[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test -[ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-1 ] unit-test -[ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-1 ] unit-test +[ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test +[ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test -[ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-1 ] unit-test -[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-1 ] unit-test -[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-1 ] unit-test -[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-1 ] unit-test +[ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test +[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test +[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test +[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test ! Labels : recursive ( ? -- ) [ f recursive ] when ; inline -[ ] [ t [ recursive ] compile-1 ] unit-test - -\ recursive compile +[ ] [ t [ recursive ] compile-call ] unit-test [ ] [ t recursive ] unit-test ! Make sure error reporting works -[ [ dup ] compile-1 ] unit-test-fails -[ [ drop ] compile-1 ] unit-test-fails +[ [ dup ] compile-call ] unit-test-fails +[ [ drop ] compile-call ] unit-test-fails diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 601a4ae63d..ddc72a0453 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -279,7 +279,7 @@ T{ x86-backend f 4 } compiler-backend set-global "-no-sse2" cli-args member? [ "Checking if your CPU supports SSE2..." print flush - [ sse2? ] compile-1 [ + [ sse2? ] compile-call [ " - yes" print "cpu.x86.sse2" require ] [ diff --git a/core/generator/generator-docs.factor b/core/generator/generator-docs.factor index b77937205a..558ed2bed8 100755 --- a/core/generator/generator-docs.factor +++ b/core/generator/generator-docs.factor @@ -19,13 +19,9 @@ $nl ABOUT: "generator" -HELP: compiled-xts +HELP: compiled { $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ; -HELP: compiling? -{ $values { "word" word } { "?" "a boolean" } } -{ $description "Tests if a word is going to be or already is compiled." } ; - HELP: compiling-word { $var-description "The word currently being compiled, set by " { $link generate-1 } "." } ; diff --git a/core/generator/generator.factor b/core/generator/generator.factor index d38f25d302..9f3851f8f1 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -4,24 +4,29 @@ 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 dlists ; +quotations sequences system threads words ; IN: generator SYMBOL: compile-queue - -SYMBOL: compiled-xts +SYMBOL: compiled : 6array 3array >r 3array r> append ; -: finish-compiling ( word literals words rel labels code -- ) - 6array swap compiled-xts get set-at ; +: begin-compiling ( word -- ) + f swap compiled get set-at ; -: compiling? ( word -- ? ) - dup compiled-xts get key? swap compiled? ; +: finish-compiling ( word literals words rel labels code -- ) + 6array swap compiled get set-at ; : queue-compile ( word -- ) - dup f compiled-xts get set-at - compile-queue get push-front ; + { + { [ dup compound? not ] [ drop ] } + { [ dup compiled get key? ] [ drop ] } + { [ t ] [ dup compile-queue get set-at ] } + } cond ; + +: maybe-compile ( word -- ) + dup compiled? [ drop ] [ queue-compile ] if ; SYMBOL: compiling-word @@ -41,7 +46,7 @@ t compiled-stack-traces? set-global literal-table get push ; : generate-1 ( word label node quot -- ) - [ + pick begin-compiling [ roll compiling-word set pick compiling-label set init-generator @@ -124,7 +129,7 @@ M: node generate-node drop iterate-next ; } cond ; : generate-call ( label -- next ) - dup queue-compile + dup maybe-compile end-basic-block tail-call? [ %jump f