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

compiler.cfg.*: changed generic emit-node to take the current block as 

stack parameter

The idea is to eventually completely remove the basic-block dynamic
variable from cfg construction.
db4
Björn Lindqvist 2016-03-05 08:30:00 +01:00
parent 6362a4ad5f
commit 07adc2ecae
7 changed files with 103 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -84,8 +84,8 @@ IN: compiler.cfg.builder.alien
base-type box-return ds-push
] if-void ;
M: #alien-invoke emit-node
params>>
M: #alien-invoke emit-node ( block node -- )
nip params>>
[
{
[ caller-parameters ]
@ -98,8 +98,8 @@ M: #alien-invoke emit-node
[ caller-return ]
bi ;
M: #alien-indirect emit-node ( node -- )
params>>
M: #alien-indirect emit-node ( block node -- )
nip params>>
[
[ ds-pop ^^unbox-any-c-ptr ] dip
[ caller-parameters ]
@ -110,8 +110,8 @@ M: #alien-indirect emit-node ( node -- )
[ caller-return ]
bi ;
M: #alien-assembly emit-node ( node -- )
params>>
M: #alien-assembly emit-node ( block node -- )
nip params>>
[
{
[ caller-parameters ]
@ -166,8 +166,8 @@ M: #alien-assembly emit-node ( node -- )
: emit-callback-return ( params -- )
basic-block get [ callee-return ##callback-outputs, ] [ drop ] if ;
M: #alien-callback emit-node
dup params>> xt>> dup
M: #alien-callback emit-node ( block node -- )
nip dup params>> xt>> dup
[
needs-frame-pointer begin-word
{

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

@ -21,7 +21,7 @@ IN: compiler.cfg.builder.blocks
: begin-basic-block ( block -- )
dup [ end-local-analysis ] when* (begin-basic-block) ;
: emit-trivial-block ( quot -- )
: emit-trivial-block ( quot: ( ..a block -- ..b ) -- )
##branch, basic-block get begin-basic-block
basic-block get [ swap call ] keep
##branch, begin-basic-block ; inline

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

@ -57,7 +57,7 @@ HELP: make-input-map
{ $examples { $unchecked-example $[ ex-make-input-map ] } } ;
HELP: emit-call
{ $values { "word" word } { "height" number } }
{ $values { "block" basic-block } { "word" word } { "height" number } }
{ $description "Emits a call to the given word to the " { $link cfg } " being constructed. \"height\" is the number of items being added to or removed from the data stack. Side effects of the word is that it modifies the \"basic-block\" and " { $link height-state } " variables." }
{ $examples
"In this example, a call to a dummy word is emitted which pushes three items onto the stack."
@ -70,7 +70,7 @@ HELP: emit-loop-call
{ $description "Sets the given block as the successor of the current block. Then ends the block." } ;
HELP: emit-node
{ $values { "node" node } }
{ $values { "block" basic-block } { "node" node } }
{ $description "Emits CFG instructions for the given SSA node." } ;
HELP: trivial-branch?

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

@ -1,13 +1,13 @@
USING: accessors alien alien.accessors arrays assocs byte-arrays
combinators.short-circuit compiler.cfg compiler.cfg.builder compiler.cfg.checker
compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.optimizer
compiler.cfg.predecessors compiler.cfg.registers compiler.cfg.representations
compiler.cfg.rpo compiler.cfg.stacks compiler.cfg.stacks.local
compiler.cfg.utilities compiler.test compiler.tree compiler.tree.builder
compiler.tree.optimizer cpu.architecture fry hashtables io kernel kernel.private
locals make math math.partial-dispatch math.private namespaces prettyprint sbufs
sequences sequences.private slots.private strings strings.private tools.test
vectors words ;
combinators.short-circuit compiler.cfg compiler.cfg.builder
compiler.cfg.checker compiler.cfg.debugger compiler.cfg.instructions
compiler.cfg.optimizer compiler.cfg.registers
compiler.cfg.stacks.local compiler.cfg.utilities compiler.test
compiler.tree compiler.tree.propagation.info cpu.architecture fry
hashtables io kernel kernel.private locals make math math.intervals
math.partial-dispatch math.private namespaces prettyprint sbufs
sequences sequences.private slots.private strings strings.private
tools.test vectors words ;
FROM: alien.c-types => int ;
IN: compiler.cfg.builder.tests
@ -247,7 +247,7 @@ IN: compiler.cfg.builder.tests
{
V{ T{ ##call { word print } } T{ ##branch } }
} [
[ \ print 4 emit-call ] V{ } make drop
[ f \ print 4 emit-call ] V{ } make drop
basic-block get successors>> first instructions>>
] cfg-unit-test
@ -256,9 +256,7 @@ IN: compiler.cfg.builder.tests
{ T{ ##load-integer { dst 78 } { val 0 } } }
} [
77 vreg-counter set-global
[
T{ #push { literal 0 } { out-d { 8537399 } } } emit-node
] { } make
[ f T{ #push { literal 0 } { out-d { 8537399 } } } emit-node ] { } make
] cfg-unit-test
{
@ -266,7 +264,7 @@ IN: compiler.cfg.builder.tests
H{ { D: -1 4 } { D: 0 4 } }
} [
4 D: 0 replace-loc
T{ #shuffle
f T{ #shuffle
{ mapping { { 2 4 } { 3 4 } } }
{ in-d V{ 4 } }
{ out-d V{ 2 3 } }
@ -288,7 +286,7 @@ IN: compiler.cfg.builder.tests
T{ ##box-alien { dst 7 } { src 5 } { temp 6 } }
}
} [
T{ #call
f T{ #call
{ word alien-cell }
{ in-d V{ 10 20 } }
{ out-d { 30 } }
@ -301,6 +299,45 @@ IN: compiler.cfg.builder.tests
basic-block get successors>> length
] unit-test
: call-node-1 ( -- node )
T{ #call
{ word set-slot }
{ in-d V{ 1 2 3 } }
{ out-d { } }
{ info
H{
{
1
T{ value-info-state
{ class object }
{ interval full-interval }
}
}
{
2
T{ value-info-state
{ class object }
{ interval full-interval }
}
}
{
3
T{ value-info-state
{ class object }
{ interval full-interval }
}
}
}
}
} ;
{
V{ T{ ##call { word set-slot } } T{ ##branch } }
} [
[ f call-node-1 emit-node ] V{ } make drop
basic-block get successors>> first instructions>>
] cfg-unit-test
! emit-loop-call
{ "bar" } [
V{ } "foo" insns>block basic-block set
@ -327,14 +364,14 @@ SYMBOL: foo
{
H{ { D: 2 1 } }
} [
T{ #shuffle { in-d { 7 3 0 } } { out-d { 55 } } { mapping { { 55 3 } } } }
f T{ #shuffle { in-d { 7 3 0 } } { out-d { 55 } } { mapping { { 55 3 } } } }
emit-node replaces get
] cfg-unit-test
{
H{ { D: -1 1 } { D: 0 1 } }
} [
T{ #shuffle
f T{ #shuffle
{ in-d { 7 } }
{ out-d { 55 77 } }
{ mapping { { 55 7 } { 77 7 } } }

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

@ -19,7 +19,7 @@ SYMBOL: loops
: begin-procedure ( word label -- )
begin-cfg procedures get push ;
: with-cfg-builder ( nodes word label quot -- )
: with-cfg-builder ( nodes word label quot: ( ..a block -- ..b ) -- )
'[
begin-stack-analysis
begin-procedure
@ -33,10 +33,10 @@ SYMBOL: loops
'[ _ t t [ drop _ call( node -- ) ] with-cfg-builder ] with-variable
] { } make drop ;
GENERIC: emit-node ( node -- )
GENERIC: emit-node ( block node -- )
: emit-nodes ( nodes -- )
[ basic-block get [ emit-node ] [ drop ] if ] each ;
[ basic-block get [ swap emit-node ] [ drop ] if* ] each ;
: begin-word ( block -- )
dup make-kill-block
@ -58,20 +58,19 @@ GENERIC: emit-node ( node -- )
##branch,
[ swap connect-bbs ] [ end-basic-block ] bi ;
: emit-call ( word height -- )
over loops get key?
[ drop loops get at basic-block get emit-loop-call ]
: emit-call ( block word height -- )
over loops get at [ 2nip swap emit-loop-call ]
[
[ emit-call-block ] emit-trivial-block
] if ;
[ emit-call-block ] emit-trivial-block drop
] if* ;
! #recursive
: recursive-height ( #recursive -- n )
[ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
: emit-recursive ( #recursive -- )
[ [ label>> id>> ] [ recursive-height ] bi emit-call ]
[ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
: emit-recursive ( block #recursive -- )
[ [ label>> id>> ] [ recursive-height ] bi emit-call ] keep
[ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ;
: remember-loop ( label block -- )
swap loops get set-at ;
@ -81,15 +80,15 @@ GENERIC: emit-node ( node -- )
[ label>> id>> basic-block get remember-loop ]
[ child>> emit-nodes ] bi ;
M: #recursive emit-node
dup label>> loop?>> [ basic-block get emit-loop ] [ emit-recursive ] if ;
M: #recursive emit-node ( block node -- )
dup label>> loop?>> [ swap emit-loop ] [ emit-recursive ] if ;
! #if
: emit-branch ( obj -- pair/f )
[ emit-nodes ] with-branch ;
: emit-if ( node -- )
children>> [ emit-branch ] map basic-block get emit-conditional ;
: emit-if ( block node -- )
children>> [ emit-branch ] map swap emit-conditional ;
: trivial-branch? ( nodes -- value ? )
dup length 1 = [
@ -114,33 +113,33 @@ M: #recursive emit-node
: emit-trivial-not-if ( -- )
[ f cc= ^^compare-imm ] unary-op ;
: emit-actual-if ( #if -- )
: emit-actual-if ( block #if -- )
! Inputs to the final instruction need to be copied because of
! loc>vreg sync
ds-pop any-rep ^^copy f cc/= ##compare-imm-branch, emit-if ;
M: #if emit-node
M: #if emit-node ( block node -- )
{
{ [ dup trivial-if? ] [ drop emit-trivial-if ] }
{ [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
{ [ dup trivial-if? ] [ 2drop emit-trivial-if ] }
{ [ dup trivial-not-if? ] [ 2drop emit-trivial-not-if ] }
[ emit-actual-if ]
} cond ;
M: #dispatch emit-node
M: #dispatch emit-node ( block node -- )
! Inputs to the final instruction need to be copied because of
! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
! though.
ds-pop ^^offset>slot next-vreg ##dispatch, emit-if ;
M: #call emit-node ( node -- )
M: #call emit-node ( block node -- )
dup word>> dup "intrinsic" word-prop
[ emit-intrinsic ] [ swap call-height emit-call ] if ;
[ nip call( node -- ) drop ] [ swap call-height emit-call ] if* ;
M: #call-recursive emit-node ( node -- )
M: #call-recursive emit-node ( block node -- )
[ label>> id>> ] [ call-height ] bi emit-call ;
M: #push emit-node
literal>> ^^load-literal ds-push ;
M: #push emit-node ( block node -- )
nip literal>> ^^load-literal ds-push ;
! #shuffle
@ -166,8 +165,9 @@ 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 ( node -- )
[ out-vregs/stack ] keep store-height-changes [ first2 store-vregs ] each ;
M: #shuffle emit-node ( block node -- )
nip [ out-vregs/stack ] keep store-height-changes
[ first2 store-vregs ] each ;
! #return
: end-word ( block -- )
@ -177,23 +177,23 @@ M: #shuffle emit-node ( node -- )
##epilogue,
##return, ;
M: #return emit-node ( node -- )
drop basic-block get end-word ;
M: #return emit-node ( block node -- )
drop end-word ;
M: #return-recursive emit-node ( node -- )
label>> id>> loops get key? [ basic-block get end-word ] unless ;
M: #return-recursive emit-node ( block node -- )
label>> id>> loops get key? [ drop ] [ end-word ] if ;
! #terminate
M: #terminate emit-node ( node -- )
drop ##no-tco, basic-block get end-basic-block ;
M: #terminate emit-node ( block node -- )
drop ##no-tco, end-basic-block ;
! No-op nodes
M: #introduce emit-node drop ;
M: #introduce emit-node 2drop ;
M: #copy emit-node drop ;
M: #copy emit-node 2drop ;
M: #enter-recursive emit-node drop ;
M: #enter-recursive emit-node 2drop ;
M: #phi emit-node drop ;
M: #phi emit-node 2drop ;
M: #declare emit-node drop ;
M: #declare emit-node 2drop ;

3
basis/compiler/cfg/intrinsics/intrinsics-docs.factor
View File

@ -1,5 +1,2 @@
USING: compiler.tree help.markup help.syntax words ;
IN: compiler.cfg.intrinsics
HELP: emit-intrinsic
{ $values { "node" node } { "word" word } }
{ $description "Emit optimized intrinsic code for a word instead of merely calling it. The \"intrinsic\" property of the word (which is expected to be a quotation) is called with the node as input." } ;

3
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -142,6 +142,3 @@ ERROR: inline-intrinsics-not-supported word quot ;
{
{ math.integers.private:fixnum-bit? [ drop [ ^^bit-test ] binary-op ] }
} enable-intrinsics ;
: emit-intrinsic ( node word -- )
"intrinsic" word-prop call( node -- ) ;