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

compiler.cfg.*: refactors words to take a block parameter instead of 

using the basic-block dynamic variable

the idea is to make the code easier to follow by limiting the use of
dynamic variables
db4
Björn Lindqvist 2015-11-19 00:53:46 +01:00
parent e1b22e0af4
commit 1421779c9e
7 changed files with 77 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/compiler/cfg/builder/alien/alien.factor
View File

@ -169,7 +169,7 @@ M: #alien-assembly emit-node ( node -- )
M: #alien-callback emit-node
dup params>> xt>> dup
[
needs-frame-pointer begin-word
needs-frame-pointer basic-block get begin-word
{
[ params>> callee-parameters ##callback-inputs, ]
[ params>> box-parameters ]

6
basis/compiler/cfg/builder/blocks/blocks-docs.factor
View File

@ -29,7 +29,8 @@ T{ basic-block
>>
HELP: begin-basic-block
{ $description "Terminates the current block and initializes a new " { $link basic-block } " to begin outputting instructions to. The new block is included in the old blocks " { $slot "successors" } "." } ;
{ $values { "block" basic-block } }
{ $description "Terminates the given block and initializes a new " { $link basic-block } " to begin outputting instructions to. The new block is included in the old blocks " { $slot "successors" } "." } ;
HELP: call-height
{ $values { "#call" #call } { "n" number } }
@ -52,7 +53,8 @@ HELP: end-branch
{ $description "pair is { final-bb final-height }" } ;
HELP: make-kill-block
{ $description "Marks the current " { $link basic-block } " being processed as a kill block." } ;
{ $values { "block" basic-block } }
{ $description "Marks the block as a kill block." } ;
HELP: set-basic-block
{ $values { "basic-block" basic-block } }

27
basis/compiler/cfg/builder/blocks/blocks-tests.factor
View File

@ -1,16 +1,27 @@
USING: accessors compiler.cfg compiler.cfg.builder.blocks compiler.cfg.stacks
compiler.cfg.utilities kernel namespaces sequences tools.test ;
USING: accessors compiler.cfg compiler.cfg.builder.blocks
compiler.cfg.stacks.local compiler.cfg.utilities compiler.test kernel
namespaces sequences tools.test ;
IN: compiler.cfg.builder.blocks.tests
! (begin-basic-block)
{ 20 } [
{ } 20 insns>block (begin-basic-block)
basic-block get predecessors>> first number>>
] cfg-unit-test
! begin-branch
{ f } [
height-state get <basic-block> begin-branch height-state get eq?
] cfg-unit-test
! make-kill-block
{ t } [
<basic-block> [ make-kill-block ] keep kill-block?>>
] unit-test
{
{ "succ" "succ" "succ" }
} [
3 [ <basic-block> ] replicate <basic-block> "succ" >>number
dupd connect-Nto1-bbs [ successors>> first number>> ] map
] unit-test
{ 33 } [
begin-stack-analysis <basic-block> 33 >>number basic-block set
(begin-basic-block)
basic-block get predecessors>> first number>>
] unit-test

44
basis/compiler/cfg/builder/blocks/blocks.factor
View File

@ -12,56 +12,56 @@ IN: compiler.cfg.builder.blocks
[ instructions>> building set ]
[ begin-local-analysis ] tri ;
: end-basic-block ( -- )
basic-block get [ end-local-analysis ] when*
building off
basic-block off ;
: end-basic-block ( block -- )
[ end-local-analysis ] when* building off basic-block off ;
: (begin-basic-block) ( -- )
<basic-block> basic-block get [ over connect-bbs ] when* set-basic-block ;
: (begin-basic-block) ( block -- )
<basic-block> swap [ over connect-bbs ] when* set-basic-block ;
: begin-basic-block ( -- )
basic-block get [ end-local-analysis ] when*
(begin-basic-block) ;
: begin-basic-block ( block -- )
dup [ end-local-analysis ] when* (begin-basic-block) ;
: emit-trivial-block ( quot -- )
##branch, begin-basic-block
##branch, basic-block get begin-basic-block
call
##branch, begin-basic-block ; inline
##branch, basic-block get begin-basic-block ; inline
: make-kill-block ( -- )
basic-block get t >>kill-block? drop ;
: make-kill-block ( block -- )
t swap kill-block?<< ;
: call-height ( #call -- n )
[ out-d>> length ] [ in-d>> length ] bi - ;
: emit-call-block ( word height -- )
adjust-d ##call, make-kill-block ;
adjust-d ##call, basic-block get make-kill-block ;
: emit-primitive ( node -- )
[
[ word>> ] [ call-height ] bi emit-call-block
] emit-trivial-block ;
: begin-branch ( -- )
height-state [ clone-height-state ] change
(begin-basic-block) ;
: begin-branch ( block -- )
height-state [ clone-height-state ] change (begin-basic-block) ;
: end-branch ( -- pair/f )
basic-block get dup [
: end-branch ( block -- pair/f )
dup [
##branch,
end-local-analysis
height-state get clone-height-state 2array
] when* ;
: with-branch ( quot -- pair/f )
[ begin-branch call end-branch ] with-scope ; inline
[
basic-block get begin-branch
call
basic-block get end-branch
] with-scope ; inline
: emit-conditional ( branches -- )
! branches is a sequence of pairs as above
end-basic-block
basic-block get end-basic-block
sift [
dup first second height-state set
begin-basic-block
basic-block get begin-basic-block
[ first ] map basic-block get connect-Nto1-bbs
] unless-empty ;

2
basis/compiler/cfg/builder/builder-docs.factor
View File

@ -62,7 +62,7 @@ HELP: emit-call
{ $see-also call-height } ;
HELP: emit-loop-call
{ $values { "basic-block" basic-block } }
{ $values { "successor-block" basic-block } { "current-block" basic-block } }
{ $description "Sets the given block as the successor of the current block. Then ends the block." } ;
HELP: emit-node

14
basis/compiler/cfg/builder/builder-tests.factor
View File

@ -297,14 +297,15 @@ IN: compiler.cfg.builder.tests
{ 1 } [
V{ } 0 insns>block basic-block set init-cfg-test
V{ } 1 insns>block [ emit-loop-call ] V{ } make drop
V{ } 1 insns>block [ basic-block get emit-loop-call ] V{ } make drop
basic-block get successors>> length
] unit-test
! emit-loop-call
{ "bar" } [
V{ } "foo" insns>block basic-block set init-cfg-test
[ V{ } "bar" insns>block emit-loop-call ] V{ } make drop
V{ } "foo" insns>block basic-block set
init-cfg-test
[ V{ } "bar" insns>block basic-block get emit-loop-call ] V{ } make drop
basic-block get successors>> first number>>
] unit-test
@ -315,6 +316,13 @@ SYMBOL: foo
\ foo f begin-cfg word>>
] cfg-unit-test
! remember-loop
{ 20 } [
H{ } clone loops set
"hello" { } 20 insns>block remember-loop
loops get "hello" of number>>
] cfg-unit-test
! store-shuffle
{
H{ { D: 2 1 } }

40
basis/compiler/cfg/builder/builder.factor
View File

@ -38,17 +38,15 @@ GENERIC: emit-node ( node -- )
: emit-nodes ( nodes -- )
[ basic-block get [ emit-node ] [ drop ] if ] each ;
: begin-word ( -- )
make-kill-block
##safepoint,
##prologue,
##branch,
: begin-word ( block -- )
dup make-kill-block
##safepoint, ##prologue, ##branch,
begin-basic-block ;
: (build-cfg) ( nodes word label -- )
[
begin-word
basic-block get begin-word
emit-nodes
] with-cfg-builder ;
@ -59,15 +57,14 @@ GENERIC: emit-node ( node -- )
] with-variable
] keep ;
: emit-loop-call ( basic-block -- )
: emit-loop-call ( successor-block current-block -- )
##safepoint,
##branch,
basic-block get swap connect-bbs
end-basic-block ;
[ swap connect-bbs ] [ end-basic-block ] bi ;
: emit-call ( word height -- )
over loops get key?
[ drop loops get at emit-loop-call ]
[ drop loops get at basic-block get emit-loop-call ]
[
[ emit-call-block ] emit-trivial-block
] if ;
@ -80,16 +77,16 @@ GENERIC: emit-node ( node -- )
[ [ label>> id>> ] [ recursive-height ] bi emit-call ]
[ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
: remember-loop ( label -- )
basic-block get swap loops get set-at ;
: remember-loop ( label block -- )
swap loops get set-at ;
: emit-loop ( node -- )
##branch,
begin-basic-block
[ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ;
: emit-loop ( node block -- )
##branch, begin-basic-block
[ label>> id>> basic-block get remember-loop ]
[ child>> emit-nodes ] bi ;
M: #recursive emit-node
dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
dup label>> loop?>> [ basic-block get emit-loop ] [ emit-recursive ] if ;
! #if
: emit-branch ( obj -- pair/f )
@ -172,14 +169,14 @@ M: #push emit-node
[ make-input-map ] [ mapping>> ] [ extract-outputs ] tri
[ first2 [ [ of of peek-loc ] 2with map ] dip 2array ] 2with map ;
M: #shuffle emit-node
M: #shuffle emit-node ( node -- )
[ out-vregs/stack ] keep store-height-changes [ first2 store-vregs ] each ;
! #return
: end-word ( -- )
##branch,
begin-basic-block
make-kill-block
basic-block get begin-basic-block
basic-block get make-kill-block
##safepoint,
##epilogue,
##return, ;
@ -190,7 +187,8 @@ M: #return-recursive emit-node
label>> id>> loops get key? [ end-word ] unless ;
! #terminate
M: #terminate emit-node drop ##no-tco, end-basic-block ;
M: #terminate emit-node ( node -- )
drop ##no-tco, basic-block get end-basic-block ;
! No-op nodes
M: #introduce emit-node drop ;