compiler.cfg.utilities: move and rename the helper words block>cfg, insns>block and insns>cfg, they are useful to many testing vocabs
parent
bc12a60a49
commit
c8a022423e
|
@ -1,19 +1,11 @@
|
||||||
USING: accessors arrays assocs compiler.cfg
|
USING: accessors arrays assocs compiler.cfg
|
||||||
compiler.cfg.dataflow-analysis.private compiler.cfg.instructions
|
compiler.cfg.dataflow-analysis.private compiler.cfg.instructions
|
||||||
compiler.cfg.linearization compiler.cfg.registers compiler.cfg.stacks.vacant
|
compiler.cfg.linearization compiler.cfg.registers
|
||||||
kernel math sequences sorting tools.test vectors ;
|
compiler.cfg.utilities compiler.cfg.stacks.vacant kernel math sequences sorting
|
||||||
|
tools.test vectors ;
|
||||||
IN: compiler.cfg.stacks.vacant.tests
|
IN: compiler.cfg.stacks.vacant.tests
|
||||||
|
|
||||||
! Utils
|
! Utils
|
||||||
: create-block ( insns n -- bb )
|
|
||||||
<basic-block> swap >>number swap >>instructions ;
|
|
||||||
|
|
||||||
: block>cfg ( bb -- cfg )
|
|
||||||
cfg new swap >>entry ;
|
|
||||||
|
|
||||||
: create-cfg ( insns -- cfg )
|
|
||||||
0 create-block block>cfg ;
|
|
||||||
|
|
||||||
: output-stack-map ( cfg -- map )
|
: output-stack-map ( cfg -- map )
|
||||||
vacant-analysis run-dataflow-analysis
|
vacant-analysis run-dataflow-analysis
|
||||||
nip [ [ number>> ] dip ] assoc-map >alist natural-sort last second ;
|
nip [ [ number>> ] dip ] assoc-map >alist natural-sort last second ;
|
||||||
|
@ -21,24 +13,24 @@ IN: compiler.cfg.stacks.vacant.tests
|
||||||
! Initially both the d and r stacks are empty.
|
! Initially both the d and r stacks are empty.
|
||||||
{
|
{
|
||||||
{ { 0 { } } { 0 { } } }
|
{ { 0 { } } { 0 { } } }
|
||||||
} [ V{ } create-cfg output-stack-map ] unit-test
|
} [ V{ } insns>cfg output-stack-map ] unit-test
|
||||||
|
|
||||||
! Raise d stack.
|
! Raise d stack.
|
||||||
{
|
{
|
||||||
{ { 1 { } } { 0 { } } }
|
{ { 1 { } } { 0 { } } }
|
||||||
} [ V{ T{ ##inc-d f 1 } } create-cfg output-stack-map ] unit-test
|
} [ V{ T{ ##inc-d f 1 } } insns>cfg output-stack-map ] unit-test
|
||||||
|
|
||||||
! Raise r stack.
|
! Raise r stack.
|
||||||
{
|
{
|
||||||
{ { 0 { } } { 1 { } } }
|
{ { 0 { } } { 1 { } } }
|
||||||
} [ V{ T{ ##inc-r f 1 } } create-cfg output-stack-map ] unit-test
|
} [ V{ T{ ##inc-r f 1 } } insns>cfg output-stack-map ] unit-test
|
||||||
|
|
||||||
! Uninitialized peeks
|
! Uninitialized peeks
|
||||||
[
|
[
|
||||||
V{
|
V{
|
||||||
T{ ##inc-d f 1 }
|
T{ ##inc-d f 1 }
|
||||||
T{ ##peek { dst 0 } { loc D 0 } }
|
T{ ##peek { dst 0 } { loc D 0 } }
|
||||||
} create-cfg
|
} insns>cfg
|
||||||
compute-vacant-sets
|
compute-vacant-sets
|
||||||
] [ vacant-peek? ] must-fail-with
|
] [ vacant-peek? ] must-fail-with
|
||||||
|
|
||||||
|
@ -46,7 +38,7 @@ IN: compiler.cfg.stacks.vacant.tests
|
||||||
V{
|
V{
|
||||||
T{ ##inc-r f 1 }
|
T{ ##inc-r f 1 }
|
||||||
T{ ##peek { dst 0 } { loc R 0 } }
|
T{ ##peek { dst 0 } { loc R 0 } }
|
||||||
} create-cfg
|
} insns>cfg
|
||||||
compute-vacant-sets
|
compute-vacant-sets
|
||||||
] [ vacant-peek? ] must-fail-with
|
] [ vacant-peek? ] must-fail-with
|
||||||
|
|
||||||
|
@ -55,7 +47,7 @@ IN: compiler.cfg.stacks.vacant.tests
|
||||||
[ ] [
|
[ ] [
|
||||||
V{
|
V{
|
||||||
T{ ##peek { dst 0 } { loc D 0 } }
|
T{ ##peek { dst 0 } { loc D 0 } }
|
||||||
} create-cfg
|
} insns>cfg
|
||||||
compute-vacant-sets
|
compute-vacant-sets
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -64,7 +56,7 @@ IN: compiler.cfg.stacks.vacant.tests
|
||||||
V{
|
V{
|
||||||
T{ ##replace { src 10 } { loc D -1 } }
|
T{ ##replace { src 10 } { loc D -1 } }
|
||||||
T{ ##peek { dst 0 } { loc D -1 } }
|
T{ ##peek { dst 0 } { loc D -1 } }
|
||||||
} create-cfg
|
} insns>cfg
|
||||||
compute-vacant-sets
|
compute-vacant-sets
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -76,7 +68,7 @@ IN: compiler.cfg.stacks.vacant.tests
|
||||||
T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
|
T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
|
||||||
T{ ##peek { dst 0 } { loc D -1 } }
|
T{ ##peek { dst 0 } { loc D -1 } }
|
||||||
}
|
}
|
||||||
[ create-cfg compute-vacant-sets ]
|
[ insns>cfg compute-vacant-sets ]
|
||||||
[ second gc-map>> check-d>> ] bi
|
[ second gc-map>> check-d>> ] bi
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -87,7 +79,7 @@ IN: compiler.cfg.stacks.vacant.tests
|
||||||
T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
|
T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
|
||||||
T{ ##inc-d f -1 }
|
T{ ##inc-d f -1 }
|
||||||
T{ ##peek { dst 0 } { loc D -1 } }
|
T{ ##peek { dst 0 } { loc D -1 } }
|
||||||
} create-cfg output-stack-map first
|
} insns>cfg output-stack-map first
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
! Should not be ok because the value wasn't initialized when gc ran.
|
! Should not be ok because the value wasn't initialized when gc ran.
|
||||||
|
@ -96,7 +88,7 @@ IN: compiler.cfg.stacks.vacant.tests
|
||||||
T{ ##inc-d f 1 }
|
T{ ##inc-d f 1 }
|
||||||
T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
|
T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
|
||||||
T{ ##peek { dst 0 } { loc D 0 } }
|
T{ ##peek { dst 0 } { loc D 0 } }
|
||||||
} create-cfg
|
} insns>cfg
|
||||||
compute-vacant-sets
|
compute-vacant-sets
|
||||||
] [ vacant-peek? ] must-fail-with
|
] [ vacant-peek? ] must-fail-with
|
||||||
|
|
||||||
|
@ -111,7 +103,7 @@ IN: compiler.cfg.stacks.vacant.tests
|
||||||
{ { 0 { } } { 0 { } } }
|
{ { 0 { } } { 0 { } } }
|
||||||
} [
|
} [
|
||||||
V{ T{ ##safepoint } T{ ##prologue } T{ ##branch } }
|
V{ T{ ##safepoint } T{ ##prologue } T{ ##branch } }
|
||||||
create-cfg output-stack-map
|
insns>cfg output-stack-map
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
{
|
{
|
||||||
|
@ -121,7 +113,7 @@ IN: compiler.cfg.stacks.vacant.tests
|
||||||
T{ ##replace { src 10 } { loc D 0 } }
|
T{ ##replace { src 10 } { loc D 0 } }
|
||||||
T{ ##replace { src 10 } { loc D 1 } }
|
T{ ##replace { src 10 } { loc D 1 } }
|
||||||
T{ ##replace { src 10 } { loc D 2 } }
|
T{ ##replace { src 10 } { loc D 2 } }
|
||||||
} create-cfg output-stack-map
|
} insns>cfg output-stack-map
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
{
|
{
|
||||||
|
@ -131,7 +123,7 @@ IN: compiler.cfg.stacks.vacant.tests
|
||||||
T{ ##replace { src 10 } { loc D 0 } }
|
T{ ##replace { src 10 } { loc D 0 } }
|
||||||
T{ ##inc-d f 1 }
|
T{ ##inc-d f 1 }
|
||||||
T{ ##replace { src 10 } { loc D 0 } }
|
T{ ##replace { src 10 } { loc D 0 } }
|
||||||
} create-cfg output-stack-map
|
} insns>cfg output-stack-map
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
{
|
{
|
||||||
|
@ -142,7 +134,7 @@ IN: compiler.cfg.stacks.vacant.tests
|
||||||
T{ ##inc-d f 1 }
|
T{ ##inc-d f 1 }
|
||||||
T{ ##replace { src 10 } { loc D 0 } }
|
T{ ##replace { src 10 } { loc D 0 } }
|
||||||
T{ ##inc-d f -1 }
|
T{ ##inc-d f -1 }
|
||||||
} create-cfg output-stack-map first
|
} insns>cfg output-stack-map first
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
{
|
{
|
||||||
|
@ -152,7 +144,7 @@ IN: compiler.cfg.stacks.vacant.tests
|
||||||
T{ ##inc-d f 1 }
|
T{ ##inc-d f 1 }
|
||||||
T{ ##replace { src 10 } { loc D 0 } }
|
T{ ##replace { src 10 } { loc D 0 } }
|
||||||
T{ ##inc-d f -1 }
|
T{ ##inc-d f -1 }
|
||||||
} create-cfg output-stack-map first
|
} insns>cfg output-stack-map first
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
{
|
{
|
||||||
|
@ -169,18 +161,18 @@ IN: compiler.cfg.stacks.vacant.tests
|
||||||
T{ ##replace { src 10 } { loc D 0 } }
|
T{ ##replace { src 10 } { loc D 0 } }
|
||||||
T{ ##inc-d f -1 }
|
T{ ##inc-d f -1 }
|
||||||
T{ ##call }
|
T{ ##call }
|
||||||
} create-cfg output-stack-map first
|
} insns>cfg output-stack-map first
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
: cfg1 ( -- cfg )
|
: cfg1 ( -- cfg )
|
||||||
V{
|
V{
|
||||||
T{ ##inc-d f 1 }
|
T{ ##inc-d f 1 }
|
||||||
T{ ##replace { src 10 } { loc D 0 } }
|
T{ ##replace { src 10 } { loc D 0 } }
|
||||||
} 0 create-block
|
} 0 insns>block
|
||||||
V{
|
V{
|
||||||
T{ ##peek { dst 37 } { loc D 0 } }
|
T{ ##peek { dst 37 } { loc D 0 } }
|
||||||
T{ ##inc-d f -1 }
|
T{ ##inc-d f -1 }
|
||||||
} 1 create-block
|
} 1 insns>block
|
||||||
1vector >>successors block>cfg ;
|
1vector >>successors block>cfg ;
|
||||||
|
|
||||||
{ { 0 { -1 } } } [ cfg1 output-stack-map first ] unit-test
|
{ { 0 { -1 } } } [ cfg1 output-stack-map first ] unit-test
|
||||||
|
@ -238,7 +230,7 @@ IN: compiler.cfg.stacks.vacant.tests
|
||||||
T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
|
T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
} [ over create-block ] assoc-map dup
|
} [ over insns>block ] assoc-map dup
|
||||||
{ { 0 1 } { 1 2 } { 2 3 } { 3 8 } { 8 10 } } make-edges 0 of block>cfg ;
|
{ { 0 1 } { 1 2 } { 2 3 } { 3 8 } { 8 10 } } make-edges 0 of block>cfg ;
|
||||||
|
|
||||||
{ { 4 { 3 2 1 -3 0 -2 -1 } } } [
|
{ { 4 { 3 2 1 -3 0 -2 -1 } } } [
|
||||||
|
|
|
@ -0,0 +1,6 @@
|
||||||
|
USING: compiler.cfg help.markup help.syntax sequences ;
|
||||||
|
IN: compiler.cfg.utilities
|
||||||
|
|
||||||
|
HELP: insert-basic-block
|
||||||
|
{ $values { "from" basic-block } { "to" basic-block } { "insns" sequence } }
|
||||||
|
{ $description "Insert basic block on the edge between 'from' and 'to'." } ;
|
|
@ -6,6 +6,15 @@ sets vectors fry arrays compiler.cfg compiler.cfg.instructions
|
||||||
compiler.cfg.rpo compiler.utilities ;
|
compiler.cfg.rpo compiler.utilities ;
|
||||||
IN: compiler.cfg.utilities
|
IN: compiler.cfg.utilities
|
||||||
|
|
||||||
|
: block>cfg ( bb -- cfg )
|
||||||
|
cfg new swap >>entry ;
|
||||||
|
|
||||||
|
: insns>block ( insns n -- bb )
|
||||||
|
<basic-block> swap >>number swap V{ } like >>instructions ;
|
||||||
|
|
||||||
|
: insns>cfg ( insns -- cfg )
|
||||||
|
0 insns>block block>cfg ;
|
||||||
|
|
||||||
: back-edge? ( from to -- ? )
|
: back-edge? ( from to -- ? )
|
||||||
[ number>> ] bi@ >= ;
|
[ number>> ] bi@ >= ;
|
||||||
|
|
||||||
|
@ -39,9 +48,7 @@ IN: compiler.cfg.utilities
|
||||||
from successors>> [ dup to eq? [ drop bb ] when ] map! drop ;
|
from successors>> [ dup to eq? [ drop bb ] when ] map! drop ;
|
||||||
|
|
||||||
:: insert-basic-block ( from to insns -- )
|
:: insert-basic-block ( from to insns -- )
|
||||||
! Insert basic block on the edge between 'from' and 'to'.
|
insns f insns>block :> bb
|
||||||
<basic-block> :> bb
|
|
||||||
insns V{ } like bb instructions<<
|
|
||||||
V{ from } bb predecessors<<
|
V{ from } bb predecessors<<
|
||||||
V{ to } bb successors<<
|
V{ to } bb successors<<
|
||||||
from to bb update-predecessors
|
from to bb update-predecessors
|
||||||
|
|
Loading…
Reference in New Issue