Get compiler going again, start re-doing redefine tests

db4
Slava Pestov 2007-12-24 21:41:46 -05:00
parent 7c75697ff3
commit bbb89af5a6
7 changed files with 115 additions and 63 deletions

View File

@ -54,4 +54,4 @@ generator command-line vocabs io prettyprint libc ;
malloc free memcpy malloc free memcpy
} compile } compile
[ compile-batch ] recompile-hook set-global [ compile ] recompile-hook set-global

View File

@ -29,27 +29,34 @@ SYMBOL: compiler-hook
"compiled-effect" set-word-prop ; "compiled-effect" set-word-prop ;
: (compile) ( word -- ) : (compile) ( word -- )
dup compiling? not over compound? and [ [
[ dup compile-begins
dup compile-begins dup word-dataflow optimize >r over dup r> generate
dup word-dataflow optimize >r over dup r> generate ] [
] [ print-error f
print-error f ] recover
] recover 2dup ripple-up save-effect ;
2dup ripple-up save-effect
] [ drop ] if ; : 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 ( words -- )
[ [
<dlist> compile-queue set H{ } clone compile-queue set
H{ } clone compiled-xts set H{ } clone compiled set
[ queue-compile ] each [ queue-compile ] each
compile-queue get [ (compile) ] dlist-slurp compile-queue get compile-loop
compiled-xts get >alist modify-code-heap compiled get >alist modify-code-heap
] with-scope ; inline ] with-scope ; inline
: compile-quot ( quot -- word ) : compile-quot ( quot -- word )
[ define-temp ] with-compilation-unit ; H{ } clone changed-words [
define-temp dup 1array compile
] with-variable ;
: compile-call ( quot -- ) : compile-call ( quot -- )
compile-quot execute ; compile-quot execute ;

View File

@ -3,3 +3,49 @@ namespaces parser tools.test words kernel sequences arrays io
effects tools.test.inference ; effects tools.test.inference ;
IN: temporary 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

60
core/compiler/test/simple.factor Normal file → Executable file
View File

@ -3,61 +3,59 @@ combinators.private ;
IN: temporary IN: temporary
! Test empty word ! Test empty word
[ ] [ [ ] compile-1 ] unit-test [ ] [ [ ] compile-call ] unit-test
! Test literals ! Test literals
[ 1 ] [ [ 1 ] compile-1 ] unit-test [ 1 ] [ [ 1 ] compile-call ] unit-test
[ 31 ] [ [ 31 ] compile-1 ] unit-test [ 31 ] [ [ 31 ] compile-call ] unit-test
[ 255 ] [ [ 255 ] compile-1 ] unit-test [ 255 ] [ [ 255 ] compile-call ] unit-test
[ -1 ] [ [ -1 ] compile-1 ] unit-test [ -1 ] [ [ -1 ] compile-call ] unit-test
[ 65536 ] [ [ 65536 ] compile-1 ] unit-test [ 65536 ] [ [ 65536 ] compile-call ] unit-test
[ -65536 ] [ [ -65536 ] compile-1 ] unit-test [ -65536 ] [ [ -65536 ] compile-call ] unit-test
[ "hey" ] [ [ "hey" ] compile-1 ] unit-test [ "hey" ] [ [ "hey" ] compile-call ] unit-test
! Calls ! Calls
: no-op ; : no-op ;
[ ] [ [ no-op ] compile-1 ] unit-test [ ] [ [ no-op ] compile-call ] unit-test
[ 3 ] [ [ no-op 3 ] compile-1 ] unit-test [ 3 ] [ [ no-op 3 ] compile-call ] unit-test
[ 3 ] [ [ 3 no-op ] compile-1 ] unit-test [ 3 ] [ [ 3 no-op ] compile-call ] unit-test
: bar 4 ; : bar 4 ;
[ 4 ] [ [ bar no-op ] compile-1 ] unit-test [ 4 ] [ [ bar no-op ] compile-call ] unit-test
[ 4 3 ] [ [ no-op bar 3 ] compile-1 ] unit-test [ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test
[ 3 4 ] [ [ 3 no-op bar ] compile-1 ] unit-test [ 3 4 ] [ [ 3 no-op bar ] compile-call ] unit-test
[ ] [ no-op ] unit-test [ ] [ no-op ] unit-test
! Conditionals ! Conditionals
[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-1 ] unit-test [ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-1 ] unit-test [ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-1 ] unit-test [ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-1 ] unit-test [ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-1 ] unit-test [ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-1 ] unit-test [ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
[ "hi" 3 ] [ 0 [ { [ "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-1 ] 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 [ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test
[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-1 ] 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-1 ] 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-1 ] unit-test [ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
! Labels ! Labels
: recursive ( ? -- ) [ f recursive ] when ; inline : recursive ( ? -- ) [ f recursive ] when ; inline
[ ] [ t [ recursive ] compile-1 ] unit-test [ ] [ t [ recursive ] compile-call ] unit-test
\ recursive compile
[ ] [ t recursive ] unit-test [ ] [ t recursive ] unit-test
! Make sure error reporting works ! Make sure error reporting works
[ [ dup ] compile-1 ] unit-test-fails [ [ dup ] compile-call ] unit-test-fails
[ [ drop ] compile-1 ] unit-test-fails [ [ drop ] compile-call ] unit-test-fails

View File

@ -279,7 +279,7 @@ T{ x86-backend f 4 } compiler-backend set-global
"-no-sse2" cli-args member? [ "-no-sse2" cli-args member? [
"Checking if your CPU supports SSE2..." print flush "Checking if your CPU supports SSE2..." print flush
[ sse2? ] compile-1 [ [ sse2? ] compile-call [
" - yes" print " - yes" print
"cpu.x86.sse2" require "cpu.x86.sse2" require
] [ ] [

View File

@ -19,13 +19,9 @@ $nl
ABOUT: "generator" ABOUT: "generator"
HELP: compiled-xts HELP: compiled
{ $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ; { $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 HELP: compiling-word
{ $var-description "The word currently being compiled, set by " { $link generate-1 } "." } ; { $var-description "The word currently being compiled, set by " { $link generate-1 } "." } ;

View File

@ -4,24 +4,29 @@ USING: arrays assocs classes combinators cpu.architecture
effects generator.fixup generator.registers generic hashtables effects generator.fixup generator.registers generic hashtables
inference inference.backend inference.dataflow io kernel inference inference.backend inference.dataflow io kernel
kernel.private layouts math namespaces optimizer prettyprint kernel.private layouts math namespaces optimizer prettyprint
quotations sequences system threads words dlists ; quotations sequences system threads words ;
IN: generator IN: generator
SYMBOL: compile-queue SYMBOL: compile-queue
SYMBOL: compiled
SYMBOL: compiled-xts
: 6array 3array >r 3array r> append ; : 6array 3array >r 3array r> append ;
: finish-compiling ( word literals words rel labels code -- ) : begin-compiling ( word -- )
6array swap compiled-xts get set-at ; f swap compiled get set-at ;
: compiling? ( word -- ? ) : finish-compiling ( word literals words rel labels code -- )
dup compiled-xts get key? swap compiled? ; 6array swap compiled get set-at ;
: queue-compile ( word -- ) : 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 SYMBOL: compiling-word
@ -41,7 +46,7 @@ t compiled-stack-traces? set-global
literal-table get push ; literal-table get push ;
: generate-1 ( word label node quot -- ) : generate-1 ( word label node quot -- )
[ pick begin-compiling [
roll compiling-word set roll compiling-word set
pick compiling-label set pick compiling-label set
init-generator init-generator
@ -124,7 +129,7 @@ M: node generate-node drop iterate-next ;
} cond ; } cond ;
: generate-call ( label -- next ) : generate-call ( label -- next )
dup queue-compile dup maybe-compile
end-basic-block end-basic-block
tail-call? [ tail-call? [
%jump f %jump f