Get compiler going again, start re-doing redefine tests
parent
7c75697ff3
commit
bbb89af5a6
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
] [
|
||||
|
|
|
@ -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 } "." } ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue