steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

2
core/bootstrap/compiler/compiler.factor
View File

@ -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

35
core/compiler/compiler.factor
View File

@ -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 -- )
[
<dlist> 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 ;

46
core/compiler/test/redefine.factor
View File

@ -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

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

@ -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

2
core/cpu/x86/32/32.factor
View File

@ -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
] [

6
core/generator/generator-docs.factor
View File

@ -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 } "." } ;

27
core/generator/generator.factor
View File

@ -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