compiler.cfg.stacks: now performs online local DCN
Slava Pestov
parent
ff7f0e2f3b
commit
d947c61bd7
|
|
@ -0,0 +1,74 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays fry kernel make math namespaces sequences
|
||||
compiler.cfg compiler.cfg.instructions compiler.cfg.stacks
|
||||
compiler.cfg.stacks.local ;
|
||||
IN: compiler.cfg.builder.blocks
|
||||
|
||||
: set-basic-block ( basic-block -- )
|
||||
[ basic-block set ] [ instructions>> building set ] bi
|
||||
begin-local-analysis ;
|
||||
|
||||
: initial-basic-block ( -- )
|
||||
<basic-block> set-basic-block ;
|
||||
|
||||
: end-basic-block ( -- )
|
||||
basic-block get [ end-local-analysis ] when
|
||||
building off
|
||||
basic-block off ;
|
||||
|
||||
: (begin-basic-block) ( -- )
|
||||
<basic-block>
|
||||
basic-block get [ dupd successors>> push ] when*
|
||||
set-basic-block ;
|
||||
|
||||
: begin-basic-block ( -- )
|
||||
basic-block get [ end-local-analysis ] when
|
||||
(begin-basic-block) ;
|
||||
|
||||
: emit-trivial-block ( quot -- )
|
||||
building get empty? [ ##branch begin-basic-block ] unless
|
||||
call
|
||||
##branch begin-basic-block ; inline
|
||||
|
||||
: call-height ( #call -- n )
|
||||
[ out-d>> length ] [ in-d>> length ] bi - ;
|
||||
|
||||
: emit-primitive ( node -- )
|
||||
[
|
||||
[ word>> ##call ]
|
||||
[ call-height adjust-d ] bi
|
||||
] emit-trivial-block ;
|
||||
|
||||
: begin-branch ( -- ) clone-current-height (begin-basic-block) ;
|
||||
|
||||
: end-branch ( -- pair/f )
|
||||
! pair is { final-bb final-height }
|
||||
basic-block get dup [
|
||||
##branch
|
||||
end-local-analysis
|
||||
current-height get clone 2array
|
||||
] when ;
|
||||
|
||||
: with-branch ( quot -- pair/f )
|
||||
[ begin-branch call end-branch ] with-scope ; inline
|
||||
|
||||
: set-successors ( branches -- )
|
||||
! Set the successor of each branch's final basic block to the
|
||||
! current block.
|
||||
basic-block get dup [
|
||||
'[ [ [ _ ] dip first successors>> push ] when* ] each
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: merge-heights ( branches -- )
|
||||
! If all elements are f, that means every branch ended with a backward
|
||||
! jump so the height is irrelevant since this block is unreachable.
|
||||
[ ] find nip [ second current-height set ] [ end-basic-block ] if* ;
|
||||
|
||||
: emit-conditional ( branches -- )
|
||||
! branchies is a sequence of pairs as above
|
||||
end-basic-block
|
||||
[ merge-heights begin-basic-block ]
|
||||
[ set-successors ]
|
||||
bi ;
|
||||
|
||||
|
|
@ -2,12 +2,12 @@ IN: compiler.cfg.builder.tests
|
|||
USING: tools.test kernel sequences words sequences.private fry
|
||||
prettyprint alien alien.accessors math.private compiler.tree.builder
|
||||
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
|
||||
compiler.cfg.predecessors compiler.cfg.checker arrays locals
|
||||
byte-arrays kernel.private math slots.private ;
|
||||
compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
|
||||
arrays locals byte-arrays kernel.private math slots.private ;
|
||||
|
||||
! Just ensure that various CFGs build correctly.
|
||||
: unit-test-cfg ( quot -- )
|
||||
'[ _ test-cfg [ compute-predecessors check-cfg ] each ] [ ] swap unit-test ;
|
||||
'[ _ test-cfg [ optimize-cfg check-cfg ] each ] [ ] swap unit-test ;
|
||||
|
||||
: blahblah ( nodes -- ? )
|
||||
{ fixnum } declare [
|
||||
|
|
|
|||
|
|
@ -10,30 +10,39 @@ compiler.tree.combinators
|
|||
compiler.tree.propagation.info
|
||||
compiler.cfg
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.stacks
|
||||
compiler.cfg.utilities
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.intrinsics
|
||||
compiler.cfg.comparisons
|
||||
compiler.cfg.stack-frame
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.predecessors
|
||||
compiler.cfg.builder.blocks
|
||||
compiler.cfg.stacks
|
||||
compiler.alien ;
|
||||
IN: compiler.cfg.builder
|
||||
|
||||
! Convert tree SSA IR to CFG SSA IR.
|
||||
! Convert tree SSA IR to CFG IR. The result is not in SSA form; this is
|
||||
! constructed later by calling compiler.cfg.ssa:construct-ssa.
|
||||
|
||||
SYMBOL: procedures
|
||||
SYMBOL: loops
|
||||
|
||||
: begin-procedure ( word label -- )
|
||||
end-basic-block
|
||||
begin-basic-block
|
||||
: begin-cfg ( word label -- cfg )
|
||||
initial-basic-block
|
||||
H{ } clone loops set
|
||||
[ basic-block get ] 2dip
|
||||
<cfg> procedures get push ;
|
||||
[ basic-block get ] 2dip <cfg> dup cfg set ;
|
||||
|
||||
: begin-procedure ( word label -- )
|
||||
begin-cfg procedures get push ;
|
||||
|
||||
: with-cfg-builder ( nodes word label quot -- )
|
||||
'[ begin-procedure @ ] with-scope ; inline
|
||||
'[
|
||||
begin-stack-analysis
|
||||
begin-procedure
|
||||
@
|
||||
end-stack-analysis
|
||||
] with-scope ; inline
|
||||
|
||||
GENERIC: emit-node ( node -- )
|
||||
|
||||
|
|
@ -61,7 +70,7 @@ GENERIC: emit-node ( node -- )
|
|||
: emit-loop-call ( basic-block -- )
|
||||
##branch
|
||||
basic-block get successors>> push
|
||||
basic-block off ;
|
||||
end-basic-block ;
|
||||
|
||||
: emit-trivial-block ( quot -- )
|
||||
basic-block get instructions>> empty? [ ##branch begin-basic-block ] unless
|
||||
|
|
@ -71,7 +80,7 @@ GENERIC: emit-node ( node -- )
|
|||
: emit-call ( word height -- )
|
||||
over loops get key?
|
||||
[ drop loops get at emit-loop-call ]
|
||||
[ [ ##call ] emit-trivial-block ]
|
||||
[ [ [ ##call ] [ adjust-d ] bi* ] emit-trivial-block ]
|
||||
if ;
|
||||
|
||||
! #recursive
|
||||
|
|
@ -169,7 +178,7 @@ M: #return-recursive emit-node
|
|||
label>> id>> loops get key? [ emit-return ] unless ;
|
||||
|
||||
! #terminate
|
||||
M: #terminate emit-node drop ##no-tco basic-block off ;
|
||||
M: #terminate emit-node drop ##no-tco end-basic-block ;
|
||||
|
||||
! FFI
|
||||
: return-size ( ctype -- n )
|
||||
|
|
@ -186,9 +195,13 @@ M: #terminate emit-node drop ##no-tco basic-block off ;
|
|||
[ return>> return-size >>return ]
|
||||
[ alien-parameters parameter-sizes drop >>params ] bi ;
|
||||
|
||||
: alien-node-height ( params -- n )
|
||||
[ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
|
||||
|
||||
: emit-alien-node ( node quot -- )
|
||||
[
|
||||
[ params>> dup <alien-stack-frame> ] dip call
|
||||
[ params>> dup dup <alien-stack-frame> ] dip call
|
||||
alien-node-height
|
||||
] emit-trivial-block ; inline
|
||||
|
||||
M: #alien-invoke emit-node
|
||||
|
|
|
|||
|
|
@ -2,8 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel compiler.cfg.instructions compiler.cfg.rpo
|
||||
compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.utilities
|
||||
compiler.cfg.dce compiler.cfg.mr combinators.short-circuit accessors
|
||||
math sequences sets assocs ;
|
||||
compiler.cfg.mr combinators.short-circuit accessors math
|
||||
sequences sets assocs ;
|
||||
IN: compiler.cfg.checker
|
||||
|
||||
ERROR: bad-kill-block bb ;
|
||||
|
|
@ -64,5 +64,5 @@ ERROR: undefined-values uses defs ;
|
|||
|
||||
: check-cfg ( cfg -- )
|
||||
[ [ check-basic-block ] each-basic-block ]
|
||||
[ eliminate-dead-code build-mr check-mr ]
|
||||
[ build-mr check-mr ]
|
||||
bi ;
|
||||
|
|
|
|||
|
|
@ -1,620 +0,0 @@
|
|||
IN: compiler.cfg.dcn.tests
|
||||
USING: tools.test kernel accessors namespaces assocs math
|
||||
cpu.architecture vectors sequences classes
|
||||
compiler.cfg
|
||||
compiler.cfg.utilities
|
||||
compiler.cfg.debugger
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.predecessors
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.checker
|
||||
compiler.cfg.dcn
|
||||
compiler.cfg.dcn.height
|
||||
compiler.cfg.dcn.local
|
||||
compiler.cfg.dcn.local.private
|
||||
compiler.cfg.dcn.global
|
||||
compiler.cfg.dcn.rewrite ;
|
||||
|
||||
: test-local-dcn ( insns -- insns' )
|
||||
<basic-block> swap >>instructions
|
||||
[ local-analysis ] keep
|
||||
instructions>> ;
|
||||
|
||||
: inserting-peeks' ( from to -- assoc )
|
||||
[ inserting-peeks ] keep untranslate-locs keys ;
|
||||
|
||||
: inserting-replaces' ( from to -- assoc )
|
||||
[ inserting-replaces ] keep untranslate-locs [ drop n>> 0 >= ] assoc-filter keys ;
|
||||
|
||||
[
|
||||
V{
|
||||
T{ ##copy f V int-regs 1 V int-regs 0 }
|
||||
T{ ##copy f V int-regs 3 V int-regs 2 }
|
||||
T{ ##copy f V int-regs 5 V int-regs 4 }
|
||||
T{ ##inc-d f -1 }
|
||||
T{ ##branch }
|
||||
}
|
||||
] [
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##peek f V int-regs 1 D 0 }
|
||||
T{ ##inc-d f -1 }
|
||||
T{ ##peek f V int-regs 2 D 0 }
|
||||
T{ ##peek f V int-regs 3 D 0 }
|
||||
T{ ##replace f V int-regs 2 D 0 }
|
||||
T{ ##replace f V int-regs 4 D 1 }
|
||||
T{ ##peek f V int-regs 5 D 1 }
|
||||
T{ ##replace f V int-regs 5 D 1 }
|
||||
T{ ##replace f V int-regs 6 D -1 }
|
||||
T{ ##branch }
|
||||
} test-local-dcn
|
||||
] unit-test
|
||||
|
||||
[
|
||||
H{
|
||||
{ V int-regs 1 V int-regs 0 }
|
||||
{ V int-regs 3 V int-regs 2 }
|
||||
{ V int-regs 5 V int-regs 4 }
|
||||
}
|
||||
] [
|
||||
copies get
|
||||
] unit-test
|
||||
|
||||
[
|
||||
H{
|
||||
{ D 0 V int-regs 0 }
|
||||
{ D 1 V int-regs 2 }
|
||||
}
|
||||
] [ reads-locations get ] unit-test
|
||||
|
||||
[
|
||||
H{
|
||||
{ D 0 V int-regs 6 }
|
||||
{ D 2 V int-regs 4 }
|
||||
}
|
||||
] [ writes-locations get ] unit-test
|
||||
|
||||
: test-global-dcn ( -- )
|
||||
cfg new 0 get >>entry
|
||||
compute-predecessors
|
||||
deconcatenatize
|
||||
drop ;
|
||||
|
||||
V{ T{ ##epilogue } T{ ##return } } 0 test-bb
|
||||
|
||||
[ ] [ test-global-dcn ] unit-test
|
||||
|
||||
V{
|
||||
T{ ##prologue }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##inc-d f 1 }
|
||||
T{ ##peek f V int-regs 0 D 1 }
|
||||
T{ ##load-immediate f V int-regs 1 100 }
|
||||
T{ ##replace f V int-regs 1 D 2 }
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##epilogue }
|
||||
T{ ##return }
|
||||
} 2 test-bb
|
||||
|
||||
0 get 1 get 1vector >>successors drop
|
||||
1 get 2 get 1vector >>successors drop
|
||||
|
||||
[ t ] [ 0 get kill-block? ] unit-test
|
||||
[ t ] [ 2 get kill-block? ] unit-test
|
||||
|
||||
[ ] [ test-global-dcn ] unit-test
|
||||
|
||||
[ t ] [ D 0 1 get peek-in key? ] unit-test
|
||||
|
||||
[ f ] [ D 0 0 get peek-in key? ] unit-test
|
||||
|
||||
[ t ] [ D 0 1 get avail-out key? ] unit-test
|
||||
|
||||
[ f ] [ D 0 0 get avail-out key? ] unit-test
|
||||
|
||||
[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test
|
||||
|
||||
[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
|
||||
|
||||
[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test
|
||||
|
||||
[ { D 2 } ] [ 1 get 2 get inserting-replaces' ] unit-test
|
||||
|
||||
V{
|
||||
T{ ##prologue }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 1 }
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##inc-d f -1 }
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##epilogue }
|
||||
T{ ##return }
|
||||
} 3 test-bb
|
||||
|
||||
0 get 1 get 1vector >>successors drop
|
||||
1 get 2 get 1vector >>successors drop
|
||||
2 get 3 get 1vector >>successors drop
|
||||
|
||||
[ ] [ test-global-dcn ] unit-test
|
||||
|
||||
[ t ] [ D 1 2 get peek-in key? ] unit-test
|
||||
[ { D 1 } ] [ 0 get 1 get inserting-peeks' ] unit-test
|
||||
[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
|
||||
|
||||
V{
|
||||
T{ ##prologue }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##inc-d f 1 }
|
||||
T{ ##peek f V int-regs 0 D 1 }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##epilogue }
|
||||
T{ ##return }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 1 D 0 }
|
||||
T{ ##peek f V int-regs 2 D 1 }
|
||||
T{ ##inc-d f 1 }
|
||||
T{ ##replace f V int-regs 2 D 1 }
|
||||
T{ ##branch }
|
||||
} 4 test-bb
|
||||
|
||||
V{
|
||||
T{ ##epilogue }
|
||||
T{ ##return }
|
||||
} 5 test-bb
|
||||
|
||||
0 get 1 get 1vector >>successors drop
|
||||
1 get 2 get 4 get V{ } 2sequence >>successors drop
|
||||
2 get 3 get 1vector >>successors drop
|
||||
4 get 5 get 1vector >>successors drop
|
||||
|
||||
[ ] [ test-global-dcn ] unit-test
|
||||
|
||||
[ f ] [ D 0 1 get avail-out key? ] unit-test
|
||||
[ f ] [ D 1 1 get avail-out key? ] unit-test
|
||||
[ t ] [ D 0 4 get peek-in key? ] unit-test
|
||||
[ t ] [ D 1 4 get peek-in key? ] unit-test
|
||||
|
||||
[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test
|
||||
[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test
|
||||
[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
|
||||
[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
|
||||
[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test
|
||||
[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test
|
||||
[ { D 1 } ] [ 1 get 4 get inserting-peeks' ] unit-test
|
||||
[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test
|
||||
[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test
|
||||
[ { D 1 } ] [ 4 get 5 get inserting-replaces' ] unit-test
|
||||
|
||||
[ t ] [ D 0 1 get peek-out key? ] unit-test
|
||||
[ f ] [ D 1 1 get peek-out key? ] unit-test
|
||||
|
||||
[ t ] [ D 1 4 get peek-in key? ] unit-test
|
||||
[ f ] [ D 1 4 get avail-in key? ] unit-test
|
||||
[ t ] [ D 1 4 get avail-out key? ] unit-test
|
||||
|
||||
V{
|
||||
T{ ##prologue }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 1 D 1 }
|
||||
T{ ##inc-d f -1 }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##load-immediate f V int-regs 2 100 }
|
||||
T{ ##replace f V int-regs 2 D 1 }
|
||||
T{ ##inc-d f -1 }
|
||||
T{ ##peek f V int-regs 4 D 1 }
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##load-immediate f V int-regs 3 100 }
|
||||
T{ ##replace f V int-regs 3 D 0 }
|
||||
T{ ##branch }
|
||||
} 4 test-bb
|
||||
|
||||
V{
|
||||
T{ ##epilogue }
|
||||
T{ ##return }
|
||||
} 5 test-bb
|
||||
|
||||
0 get 1 get 1vector >>successors drop
|
||||
1 get 2 get 3 get V{ } 2sequence >>successors drop
|
||||
2 get 4 get 1vector >>successors drop
|
||||
3 get 4 get 1vector >>successors drop
|
||||
4 get 5 get 1vector >>successors drop
|
||||
|
||||
[ ] [ test-global-dcn ] unit-test
|
||||
|
||||
[ t ] [ D 1 4 get avail-in key? ] unit-test
|
||||
[ f ] [ D 2 4 get avail-in key? ] unit-test
|
||||
[ t ] [ D 1 2 get peek-in key? ] unit-test
|
||||
[ f ] [ D 1 3 get peek-in key? ] unit-test
|
||||
|
||||
[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test
|
||||
[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test
|
||||
[ { D 1 } ] [ 1 get 2 get inserting-peeks' ] unit-test
|
||||
[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
|
||||
[ { D 2 } ] [ 1 get 3 get inserting-peeks' ] unit-test
|
||||
[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test
|
||||
[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test
|
||||
[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test
|
||||
[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test
|
||||
[ { D 0 } ] [ 4 get 5 get inserting-replaces' ] unit-test
|
||||
|
||||
V{
|
||||
T{ ##prologue }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 1 }
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##inc-d f -1 }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##call f drop -1 }
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 1 D 0 }
|
||||
T{ ##branch }
|
||||
} 4 test-bb
|
||||
|
||||
V{
|
||||
T{ ##epilogue }
|
||||
T{ ##return }
|
||||
} 5 test-bb
|
||||
|
||||
[ t ] [ 0 get kill-block? ] unit-test
|
||||
[ t ] [ 3 get kill-block? ] unit-test
|
||||
|
||||
0 get 1 get 1vector >>successors drop
|
||||
1 get 2 get 3 get V{ } 2sequence >>successors drop
|
||||
2 get 4 get 1vector >>successors drop
|
||||
3 get 4 get 1vector >>successors drop
|
||||
4 get 5 get 1vector >>successors drop
|
||||
|
||||
[ ] [ test-global-dcn ] unit-test
|
||||
|
||||
[ t ] [ D 1 2 get avail-out key? ] unit-test
|
||||
[ f ] [ D 1 3 get peek-out key? ] unit-test
|
||||
[ f ] [ D 1 3 get avail-out key? ] unit-test
|
||||
[ f ] [ D 1 4 get avail-in key? ] unit-test
|
||||
|
||||
[ { D 1 } ] [ 0 get 1 get inserting-peeks' ] unit-test
|
||||
[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
|
||||
[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test
|
||||
[ { } ] [ 2 get 4 get inserting-peeks' ] unit-test
|
||||
[ { D 0 } ] [ 3 get 4 get inserting-peeks' ] unit-test
|
||||
|
||||
V{
|
||||
T{ ##prologue }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{ T{ ##epilogue } T{ ##return } } 2 test-bb
|
||||
|
||||
V{ T{ ##branch } } 3 test-bb
|
||||
|
||||
0 get 1 get 1vector >>successors drop
|
||||
1 get 2 get 3 get V{ } 2sequence >>successors drop
|
||||
3 get 1 get 1vector >>successors drop
|
||||
|
||||
[ ] [ test-global-dcn ] unit-test
|
||||
|
||||
[ t ] [ D 0 1 get avail-out key? ] unit-test
|
||||
|
||||
[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test
|
||||
[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
|
||||
[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test
|
||||
[ { } ] [ 3 get 1 get inserting-peeks' ] unit-test
|
||||
|
||||
V{
|
||||
T{ ##prologue }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##call f drop }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##branch }
|
||||
} 4 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 1 D 0 }
|
||||
T{ ##branch }
|
||||
} 5 test-bb
|
||||
|
||||
V{
|
||||
T{ ##epilogue }
|
||||
T{ ##return }
|
||||
} 6 test-bb
|
||||
|
||||
0 get 1 get 1vector >>successors drop
|
||||
1 get 2 get 3 get V{ } 2sequence >>successors drop
|
||||
2 get 4 get 1vector >>successors drop
|
||||
3 get 4 get 1vector >>successors drop
|
||||
4 get 5 get 1vector >>successors drop
|
||||
5 get 6 get 1vector >>successors drop
|
||||
|
||||
[ ] [ test-global-dcn ] unit-test
|
||||
|
||||
[ { } ] [ 0 get 1 get inserting-peeks' ] unit-test
|
||||
[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
|
||||
[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test
|
||||
[ { D 0 } ] [ 2 get 4 get inserting-peeks' ] unit-test
|
||||
[ { D 0 } ] [ 1 get 3 get inserting-peeks' ] unit-test
|
||||
[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test
|
||||
[ { } ] [ 5 get 6 get inserting-peeks' ] unit-test
|
||||
|
||||
V{
|
||||
T{ ##prologue }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##load-immediate f V int-regs 1 100 }
|
||||
T{ ##replace f V int-regs 1 D 0 }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 2 D 0 }
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##branch }
|
||||
} 4 test-bb
|
||||
|
||||
V{
|
||||
T{ ##epilogue }
|
||||
T{ ##return }
|
||||
} 5 test-bb
|
||||
|
||||
0 get 1 get 1vector >>successors drop
|
||||
1 get 2 get 3 get V{ } 2sequence >>successors drop
|
||||
2 get 4 get 1vector >>successors drop
|
||||
3 get 4 get 1vector >>successors drop
|
||||
4 get 5 get 1vector >>successors drop
|
||||
|
||||
[ ] [ test-global-dcn ] unit-test
|
||||
|
||||
[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
|
||||
[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
|
||||
[ { D 0 } ] [ 1 get 3 get inserting-peeks' ] unit-test
|
||||
[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test
|
||||
[ { } ] [ 2 get 4 get inserting-peeks' ] unit-test
|
||||
[ { D 0 } ] [ 2 get 4 get inserting-replaces' ] unit-test
|
||||
[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test
|
||||
[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test
|
||||
[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test
|
||||
[ { } ] [ 4 get 5 get inserting-replaces' ] unit-test
|
||||
|
||||
V{
|
||||
T{ ##prologue }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##load-immediate f V int-regs 1 100 }
|
||||
T{ ##replace f V int-regs 1 D 0 }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##load-immediate f V int-regs 2 100 }
|
||||
T{ ##replace f V int-regs 2 D 0 }
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 4 test-bb
|
||||
|
||||
V{
|
||||
T{ ##epilogue }
|
||||
T{ ##return }
|
||||
} 5 test-bb
|
||||
|
||||
0 get 1 get 1vector >>successors drop
|
||||
1 get 2 get 3 get V{ } 2sequence >>successors drop
|
||||
2 get 4 get 1vector >>successors drop
|
||||
3 get 4 get 1vector >>successors drop
|
||||
4 get 5 get 1vector >>successors drop
|
||||
|
||||
[ ] [ test-global-dcn ] unit-test
|
||||
|
||||
[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test
|
||||
|
||||
[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test
|
||||
|
||||
[ { D 0 } ] [ 4 get 5 get inserting-replaces' ] unit-test
|
||||
|
||||
! Dead replace elimination
|
||||
V{
|
||||
T{ ##prologue }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##peek f V int-regs 1 D 1 }
|
||||
T{ ##replace f V int-regs 1 D 0 }
|
||||
T{ ##replace f V int-regs 0 D 1 }
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##inc-d f -2 }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##epilogue }
|
||||
T{ ##return }
|
||||
} 3 test-bb
|
||||
|
||||
0 get 1 get 1vector >>successors drop
|
||||
1 get 2 get 1vector >>successors drop
|
||||
2 get 3 get 1vector >>successors drop
|
||||
|
||||
[ ] [ test-global-dcn ] unit-test
|
||||
|
||||
[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test
|
||||
[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
|
||||
[ { } ] [ 2 get 3 get inserting-replaces' ] unit-test
|
||||
|
||||
! More dead replace elimination tests
|
||||
V{
|
||||
T{ ##prologue }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek { dst V int-regs 10 } { loc D 0 } }
|
||||
T{ ##inc-d { n -1 } }
|
||||
T{ ##inc-r { n 1 } }
|
||||
T{ ##replace { src V int-regs 10 } { loc R 0 } }
|
||||
T{ ##peek { dst V int-regs 12 } { loc R 0 } }
|
||||
T{ ##inc-r { n -1 } }
|
||||
T{ ##inc-d { n 1 } }
|
||||
T{ ##replace { src V int-regs 12 } { loc D 0 } }
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##epilogue }
|
||||
T{ ##return }
|
||||
} 2 test-bb
|
||||
|
||||
0 get 1 get 1vector >>successors drop
|
||||
1 get 2 get 1vector >>successors drop
|
||||
|
||||
[ ] [ test-global-dcn ] unit-test
|
||||
|
||||
[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
|
||||
|
||||
! Check that retain stack usage works
|
||||
V{
|
||||
T{ ##prologue }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##inc-d f -1 }
|
||||
T{ ##inc-r f 1 }
|
||||
T{ ##replace f V int-regs 0 R 0 }
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##call f + -1 }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 R 0 }
|
||||
T{ ##inc-r f -1 }
|
||||
T{ ##inc-d f 1 }
|
||||
T{ ##replace f V int-regs 0 D 0 }
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##epilogue }
|
||||
T{ ##return }
|
||||
} 4 test-bb
|
||||
|
||||
0 get 1 get 1vector >>successors drop
|
||||
1 get 2 get 1vector >>successors drop
|
||||
2 get 3 get 1vector >>successors drop
|
||||
3 get 4 get 1vector >>successors drop
|
||||
|
||||
[ ] [ test-global-dcn ] unit-test
|
||||
|
||||
[ ##replace D 0 ] [
|
||||
3 get successors>> first instructions>> first
|
||||
[ class ] [ loc>> ] bi
|
||||
] unit-test
|
||||
|
||||
[ ##replace R 0 ] [
|
||||
1 get successors>> first instructions>> first
|
||||
[ class ] [ loc>> ] bi
|
||||
] unit-test
|
||||
|
||||
[ ##peek R 0 ] [
|
||||
2 get successors>> first instructions>> first
|
||||
[ class ] [ loc>> ] bi
|
||||
] unit-test
|
||||
|
|
@ -1,44 +0,0 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators
|
||||
compiler.cfg
|
||||
compiler.cfg.dcn.height
|
||||
compiler.cfg.dcn.local
|
||||
compiler.cfg.dcn.global
|
||||
compiler.cfg.dcn.rewrite ;
|
||||
IN: compiler.cfg.dcn
|
||||
|
||||
! "DeConcatenatizatioN" -- dataflow analysis to recover registers
|
||||
! from stack locations.
|
||||
|
||||
! Local sets:
|
||||
! - P(b): locations that block b peeks before replacing
|
||||
! - R(b): locations that block b replaces
|
||||
! - A(b): P(b) \/ R(b) -- locations that are available in registers at the end of b
|
||||
|
||||
! Global sets:
|
||||
! - P_out(b) = /\ P_in(sux) for sux in successors(b)
|
||||
! - P_in(b) = (P_out(b) - R(b)) \/ P(b)
|
||||
!
|
||||
! - R_in(b) = R_out(b) \/ R(b)
|
||||
! - R_out(b) = \/ R_in(sux) for sux in successors(b)
|
||||
!
|
||||
! - A_in(b) = /\ A_out(pred) for pred in predecessors(b)
|
||||
! - A_out(b) = A_in(b) \/ P(b) \/ R(b)
|
||||
|
||||
! On every edge [b --> sux], insert a replace for each location in
|
||||
! R_out(b) - R_in(sux)
|
||||
|
||||
! On every edge [pred --> b], insert a peek for each location in
|
||||
! P_in(b) - (P_out(pred) \/ A_out(pred))
|
||||
|
||||
! Locations are height-normalized.
|
||||
|
||||
: deconcatenatize ( cfg -- cfg' )
|
||||
{
|
||||
[ compute-heights ]
|
||||
[ compute-local-sets ]
|
||||
[ compute-global-sets ]
|
||||
[ rewrite ]
|
||||
[ cfg-changed ]
|
||||
} cleave ;
|
||||
|
|
@ -1,82 +0,0 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces assocs accessors sequences kernel math locals fry
|
||||
compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.registers ;
|
||||
IN: compiler.cfg.dcn.height
|
||||
|
||||
! Compute block in-height and out-height sets. These are relative to the
|
||||
! stack height from the start of the procedure.
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOLS: in-ds-heights out-ds-heights in-rs-heights out-rs-heights ;
|
||||
|
||||
GENERIC: ds-height-change ( insn -- n )
|
||||
|
||||
M: insn ds-height-change drop 0 ;
|
||||
|
||||
M: ##inc-d ds-height-change n>> ;
|
||||
|
||||
M: ##call ds-height-change height>> ;
|
||||
|
||||
: alien-node-height ( node -- n )
|
||||
params>> [ out-d>> length ] [ in-d>> length ] bi - ;
|
||||
|
||||
M: ##alien-invoke ds-height-change alien-node-height ;
|
||||
|
||||
M: ##alien-indirect ds-height-change alien-node-height ;
|
||||
|
||||
GENERIC: rs-height-change ( insn -- n )
|
||||
|
||||
M: insn rs-height-change drop 0 ;
|
||||
|
||||
M: ##inc-r rs-height-change n>> ;
|
||||
|
||||
:: compute-in-height ( bb in out -- )
|
||||
bb predecessors>> [ out at ] map-find drop 0 or
|
||||
bb in set-at ;
|
||||
|
||||
:: compute-out-height ( bb in out quot -- )
|
||||
bb instructions>>
|
||||
bb in at
|
||||
[ quot call + ] reduce
|
||||
bb out set-at ; inline
|
||||
|
||||
:: compute-height ( bb in out quot -- )
|
||||
bb in get out get
|
||||
[ compute-in-height ]
|
||||
[ quot compute-out-height ] 3bi ; inline
|
||||
|
||||
: compute-ds-height ( bb -- )
|
||||
in-ds-heights out-ds-heights [ ds-height-change ] compute-height ;
|
||||
|
||||
: compute-rs-height ( bb -- )
|
||||
in-rs-heights out-rs-heights [ rs-height-change ] compute-height ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: compute-heights ( cfg -- )
|
||||
H{ } clone in-ds-heights set
|
||||
H{ } clone out-ds-heights set
|
||||
H{ } clone in-rs-heights set
|
||||
H{ } clone out-rs-heights set
|
||||
[
|
||||
[ compute-rs-height ]
|
||||
[ compute-ds-height ] bi
|
||||
] each-basic-block ;
|
||||
|
||||
GENERIC# translate-loc 1 ( loc bb -- loc' )
|
||||
|
||||
M: ds-loc translate-loc [ n>> ] [ in-ds-heights get at ] bi* - <ds-loc> ;
|
||||
M: rs-loc translate-loc [ n>> ] [ in-rs-heights get at ] bi* - <rs-loc> ;
|
||||
|
||||
: translate-locs ( assoc bb -- assoc' )
|
||||
'[ [ _ translate-loc ] dip ] assoc-map ;
|
||||
|
||||
GENERIC# untranslate-loc 1 ( loc bb -- loc' )
|
||||
|
||||
M: ds-loc untranslate-loc [ n>> ] [ in-ds-heights get at ] bi* + <ds-loc> ;
|
||||
M: rs-loc untranslate-loc [ n>> ] [ in-rs-heights get at ] bi* + <rs-loc> ;
|
||||
|
||||
: untranslate-locs ( assoc bb -- assoc' )
|
||||
'[ [ _ untranslate-loc ] dip ] assoc-map ;
|
||||
|
|
@ -1,101 +0,0 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs kernel make namespaces sequences math
|
||||
compiler.cfg.rpo compiler.cfg.registers compiler.cfg.instructions
|
||||
compiler.cfg.dcn.height ;
|
||||
IN: compiler.cfg.dcn.local
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: copies
|
||||
|
||||
: record-copy ( dst src -- ) swap copies get set-at ;
|
||||
|
||||
: resolve-copy ( vreg -- vreg' ) copies get ?at drop ;
|
||||
|
||||
SYMBOLS: reads-locations writes-locations ;
|
||||
|
||||
: loc>vreg ( loc -- vreg )
|
||||
dup writes-locations get at
|
||||
[ ] [ reads-locations get at ] ?if ;
|
||||
|
||||
SYMBOL: ds-height
|
||||
|
||||
SYMBOL: rs-height
|
||||
|
||||
GENERIC: translate-loc ( loc -- loc' )
|
||||
|
||||
M: ds-loc translate-loc n>> ds-height get - <ds-loc> ;
|
||||
|
||||
M: rs-loc translate-loc n>> rs-height get - <rs-loc> ;
|
||||
|
||||
GENERIC: visit ( insn -- )
|
||||
|
||||
M: insn visit , ;
|
||||
|
||||
M: ##inc-d visit n>> ds-height [ + ] change ;
|
||||
|
||||
M: ##inc-r visit n>> rs-height [ + ] change ;
|
||||
|
||||
M: ##peek visit
|
||||
! If location is in a register already, copy existing
|
||||
! register to destination. Otherwise, associate the
|
||||
! location with the register.
|
||||
[ dst>> ] [ loc>> translate-loc ] bi dup loc>vreg
|
||||
[ [ record-copy ] [ ##copy ] 2bi ]
|
||||
[ reads-locations get set-at ]
|
||||
?if ;
|
||||
|
||||
M: ##replace visit
|
||||
! If location already contains the same value, do nothing.
|
||||
! Otherwise, associate the location with the register.
|
||||
[ src>> resolve-copy ] [ loc>> translate-loc ] bi 2dup loc>vreg =
|
||||
[ 2drop ] [ writes-locations get set-at ] if ;
|
||||
|
||||
M: ##copy visit
|
||||
! Not needed at this point because IR doesn't have ##copy
|
||||
! on input to dcn pass, but in the future it might.
|
||||
[ dst>> ] [ src>> resolve-copy ] bi record-copy ;
|
||||
|
||||
: insert-height-changes ( -- )
|
||||
ds-height get dup 0 = [ drop ] [ ##inc-d ] if
|
||||
rs-height get dup 0 = [ drop ] [ ##inc-r ] if ;
|
||||
|
||||
: init-local-analysis ( -- )
|
||||
0 ds-height set
|
||||
0 rs-height set
|
||||
H{ } clone copies set
|
||||
H{ } clone reads-locations set
|
||||
H{ } clone writes-locations set ;
|
||||
|
||||
: local-analysis ( bb -- )
|
||||
! Removes all ##peek and ##replace from the basic block.
|
||||
! Conceptually, moves all ##peeks to the start
|
||||
! (reads-locations assoc) and all ##replaces to the end
|
||||
! (writes-locations assoc).
|
||||
init-local-analysis
|
||||
[
|
||||
[
|
||||
unclip-last-slice [ [ visit ] each ] dip
|
||||
insert-height-changes
|
||||
,
|
||||
] V{ } make
|
||||
] change-instructions drop ;
|
||||
|
||||
SYMBOLS: peeks replaces ;
|
||||
|
||||
: visit-block ( bb -- )
|
||||
[ local-analysis ]
|
||||
[ [ reads-locations get ] dip [ translate-locs ] keep peeks get set-at ]
|
||||
[ [ writes-locations get ] dip [ translate-locs ] keep replaces get set-at ]
|
||||
tri ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: peek ( bb -- assoc ) peeks get at ;
|
||||
: replace ( bb -- assoc ) replaces get at ;
|
||||
|
||||
: compute-local-sets ( cfg -- )
|
||||
H{ } clone peeks set
|
||||
H{ } clone replaces set
|
||||
[ visit-block ] each-basic-block ;
|
||||
|
|
@ -52,7 +52,7 @@ INSN: ##inc-d { n integer } ;
|
|||
INSN: ##inc-r { n integer } ;
|
||||
|
||||
! Subroutine calls
|
||||
INSN: ##call word { height integer } ;
|
||||
INSN: ##call word ;
|
||||
INSN: ##jump word ;
|
||||
INSN: ##return ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,10 +1,9 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences alien math classes.algebra
|
||||
fry locals combinators cpu.architecture
|
||||
compiler.tree.propagation.info
|
||||
USING: accessors kernel sequences alien math classes.algebra fry
|
||||
locals combinators cpu.architecture compiler.tree.propagation.info
|
||||
compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions
|
||||
compiler.cfg.utilities ;
|
||||
compiler.cfg.utilities compiler.cfg.builder.blocks ;
|
||||
IN: compiler.cfg.intrinsics.alien
|
||||
|
||||
: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.order sequences accessors arrays
|
||||
byte-arrays layouts classes.tuple.private fry locals
|
||||
compiler.tree.propagation.info compiler.cfg.hats
|
||||
compiler.cfg.instructions compiler.cfg.stacks
|
||||
compiler.cfg.utilities ;
|
||||
compiler.cfg.utilities compiler.cfg.builder.blocks ;
|
||||
IN: compiler.cfg.intrinsics.allot
|
||||
|
||||
: ##set-slots ( regs obj class -- )
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@ compiler.cfg.hats
|
|||
compiler.cfg.stacks
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.utilities
|
||||
compiler.cfg.builder.blocks
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.comparisons ;
|
||||
IN: compiler.cfg.intrinsics.fixnum
|
||||
|
|
@ -31,7 +32,7 @@ IN: compiler.cfg.intrinsics.fixnum
|
|||
[ ^^untag-fixnum ^^neg ^^sar dup tag-mask get ^^and-imm ^^xor ] emit-fixnum-op ;
|
||||
|
||||
: emit-fixnum-shift-general ( -- )
|
||||
D 0 ^^peek 0 cc> ##compare-imm-branch
|
||||
ds-peek 0 cc> ##compare-imm-branch
|
||||
[ emit-fixnum-left-shift ] with-branch
|
||||
[ emit-fixnum-right-shift ] with-branch
|
||||
2array emit-conditional ;
|
||||
|
|
@ -62,13 +63,13 @@ IN: compiler.cfg.intrinsics.fixnum
|
|||
ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
|
||||
|
||||
: emit-no-overflow-case ( dst -- final-bb )
|
||||
[ -2 ##inc-d ds-push ] with-branch ;
|
||||
[ ds-drop ds-drop ds-push ] with-branch ;
|
||||
|
||||
: emit-overflow-case ( word -- final-bb )
|
||||
[ -1 ##call ] with-branch ;
|
||||
[ ##call -1 adjust-d ] with-branch ;
|
||||
|
||||
: emit-fixnum-overflow-op ( quot word -- )
|
||||
[ [ D 1 ^^peek D 0 ^^peek ] dip call ] dip
|
||||
[ [ (2inputs) ] dip call ] dip
|
||||
[ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
|
||||
emit-conditional ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: layouts namespaces kernel accessors sequences
|
||||
classes.algebra compiler.tree.propagation.info
|
||||
compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
|
||||
compiler.cfg.utilities ;
|
||||
compiler.cfg.utilities compiler.cfg.builder.blocks ;
|
||||
IN: compiler.cfg.intrinsics.slots
|
||||
|
||||
: value-tag ( info -- n ) class>> class-tag ; inline
|
||||
|
|
|
|||
|
|
@ -25,11 +25,12 @@ M: insn linearize-insn , drop ;
|
|||
#! don't need to branch.
|
||||
[ number>> ] bi@ 1 - = ; inline
|
||||
|
||||
: emit-loop-entry? ( bb -- ? )
|
||||
dup predecessors>> [ swap back-edge? ] with any? ;
|
||||
: emit-loop-entry? ( bb successor -- ? )
|
||||
[ back-edge? not ]
|
||||
[ nip dup predecessors>> [ swap back-edge? ] with any? ] 2bi and ;
|
||||
|
||||
: emit-branch ( bb successor -- )
|
||||
dup emit-loop-entry? [ _loop-entry ] when
|
||||
2dup emit-loop-entry? [ _loop-entry ] when
|
||||
2dup useless-branch? [ 2drop ] [ nip number>> _branch ] if ;
|
||||
|
||||
M: ##branch linearize-insn
|
||||
|
|
|
|||
|
|
@ -4,7 +4,6 @@ USING: kernel sequences accessors combinators namespaces
|
|||
compiler.cfg.tco
|
||||
compiler.cfg.predecessors
|
||||
compiler.cfg.useless-conditionals
|
||||
compiler.cfg.dcn
|
||||
compiler.cfg.ssa
|
||||
compiler.cfg.branch-splitting
|
||||
compiler.cfg.block-joining
|
||||
|
|
@ -35,7 +34,6 @@ SYMBOL: check-optimizer?
|
|||
split-branches
|
||||
join-blocks
|
||||
compute-predecessors
|
||||
deconcatenatize
|
||||
construct-ssa
|
||||
alias-analysis
|
||||
value-numbering
|
||||
|
|
|
|||
|
|
@ -2,13 +2,11 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces assocs kernel fry accessors sequences make math
|
||||
combinators compiler.cfg compiler.cfg.hats compiler.cfg.instructions
|
||||
compiler.cfg.utilities compiler.cfg.rpo compiler.cfg.dcn.local
|
||||
compiler.cfg.dcn.global compiler.cfg.dcn.height ;
|
||||
IN: compiler.cfg.dcn.rewrite
|
||||
compiler.cfg.utilities compiler.cfg.rpo compiler.cfg.stacks.local
|
||||
compiler.cfg.stacks.global compiler.cfg.stacks.height ;
|
||||
IN: compiler.cfg.stacks.finalize
|
||||
|
||||
! This pass inserts peeks, replaces, and copies. All stack locations
|
||||
! are loaded to canonical vregs, with a 1-1 mapping from location to
|
||||
! vreg. SSA is reconstructed afterwards.
|
||||
! This pass inserts peeks and replaces.
|
||||
|
||||
: inserting-peeks ( from to -- assoc )
|
||||
peek-in swap [ peek-out ] [ avail-out ] bi
|
||||
|
|
@ -18,10 +16,6 @@ IN: compiler.cfg.dcn.rewrite
|
|||
[ replace-out ] [ [ kill-in ] [ replace-in ] bi ] bi*
|
||||
assoc-union assoc-diff ;
|
||||
|
||||
SYMBOL: locs>vregs
|
||||
|
||||
: loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ;
|
||||
|
||||
: each-insertion ( assoc bb quot: ( vreg loc -- ) -- )
|
||||
'[ drop [ loc>vreg ] [ _ untranslate-loc ] bi @ ] assoc-each ; inline
|
||||
|
||||
|
|
@ -39,30 +33,9 @@ ERROR: bad-peek dst loc ;
|
|||
2dup [ [ insert-peeks ] [ insert-replaces ] 2bi ] V{ } make
|
||||
[ 2drop ] [ <simple-block> insert-basic-block ] if-empty ;
|
||||
|
||||
: visit-edges ( bb -- )
|
||||
: visit-block ( bb -- )
|
||||
[ predecessors>> ] keep '[ _ visit-edge ] each ;
|
||||
|
||||
: insert-in-copies ( bb -- )
|
||||
peek [ swap loc>vreg ##copy ] assoc-each ;
|
||||
|
||||
: insert-out-copies ( bb -- )
|
||||
replace [ swap loc>vreg swap ##copy ] assoc-each ;
|
||||
|
||||
: rewrite-instructions ( bb -- )
|
||||
[
|
||||
[
|
||||
{
|
||||
[ insert-in-copies ]
|
||||
[ instructions>> but-last-slice % ]
|
||||
[ insert-out-copies ]
|
||||
[ instructions>> last , ]
|
||||
} cleave
|
||||
] V{ } make
|
||||
] keep (>>instructions) ;
|
||||
|
||||
: visit-block ( bb -- )
|
||||
[ visit-edges ] [ rewrite-instructions ] bi ;
|
||||
|
||||
: rewrite ( cfg -- )
|
||||
H{ } clone locs>vregs set
|
||||
[ visit-block ] each-basic-block ;
|
||||
: finalize-stack-shuffling ( cfg -- cfg' )
|
||||
dup [ visit-block ] each-basic-block
|
||||
cfg-changed ;
|
||||
|
|
@ -1,38 +1,39 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs kernel combinators compiler.cfg.dataflow-analysis
|
||||
compiler.cfg.dcn.local ;
|
||||
IN: compiler.cfg.dcn.global
|
||||
compiler.cfg.stacks.local ;
|
||||
IN: compiler.cfg.stacks.global
|
||||
|
||||
! Peek analysis. Peek-in is the set of all locations anticipated at
|
||||
! the start of a basic block.
|
||||
BACKWARD-ANALYSIS: peek
|
||||
|
||||
M: peek-analysis transfer-set drop [ replace assoc-diff ] keep peek assoc-union ;
|
||||
M: peek-analysis transfer-set drop [ replace-set assoc-diff ] keep peek-set assoc-union ;
|
||||
|
||||
! Replace analysis. Replace-in is the set of all locations which
|
||||
! will be overwritten at some point after the start of a basic block.
|
||||
FORWARD-ANALYSIS: replace
|
||||
|
||||
M: replace-analysis transfer-set drop replace assoc-union ;
|
||||
M: replace-analysis transfer-set drop replace-set assoc-union ;
|
||||
|
||||
! Availability analysis. Avail-out is the set of all locations
|
||||
! in registers at the end of a basic block.
|
||||
FORWARD-ANALYSIS: avail
|
||||
|
||||
M: avail-analysis transfer-set drop [ peek ] [ replace ] bi assoc-union assoc-union ;
|
||||
M: avail-analysis transfer-set drop [ peek-set ] [ replace-set ] bi assoc-union assoc-union ;
|
||||
|
||||
! Kill analysis. Kill-in is the set of all locations
|
||||
! which are going to be overwritten.
|
||||
BACKWARD-ANALYSIS: kill
|
||||
|
||||
M: kill-analysis transfer-set drop replace assoc-union ;
|
||||
M: kill-analysis transfer-set drop replace-set assoc-union ;
|
||||
|
||||
! Main word
|
||||
: compute-global-sets ( cfg -- )
|
||||
: compute-global-sets ( cfg -- cfg' )
|
||||
{
|
||||
[ compute-peek-sets ]
|
||||
[ compute-replace-sets ]
|
||||
[ compute-avail-sets ]
|
||||
[ compute-kill-sets ]
|
||||
[ ]
|
||||
} cleave ;
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs fry kernel math
|
||||
namespaces compiler.cfg.registers ;
|
||||
IN: compiler.cfg.stacks.height
|
||||
|
||||
! Global stack height tracking done while constructing CFG.
|
||||
SYMBOLS: ds-heights rs-heights ;
|
||||
|
||||
: record-stack-heights ( ds-height rs-height bb -- )
|
||||
[ ds-heights get set-at ] [ rs-heights get set-at ] bi-curry bi* ;
|
||||
|
||||
GENERIC# translate-loc 1 ( loc bb -- loc' )
|
||||
|
||||
M: ds-loc translate-loc [ n>> ] [ ds-heights get at ] bi* - <ds-loc> ;
|
||||
M: rs-loc translate-loc [ n>> ] [ rs-heights get at ] bi* - <rs-loc> ;
|
||||
|
||||
: translate-locs ( assoc bb -- assoc' )
|
||||
'[ [ _ translate-loc ] dip ] assoc-map ;
|
||||
|
||||
GENERIC# untranslate-loc 1 ( loc bb -- loc' )
|
||||
|
||||
M: ds-loc untranslate-loc [ n>> ] [ ds-heights get at ] bi* + <ds-loc> ;
|
||||
M: rs-loc untranslate-loc [ n>> ] [ rs-heights get at ] bi* + <rs-loc> ;
|
||||
|
||||
: untranslate-locs ( assoc bb -- assoc' )
|
||||
'[ [ _ untranslate-loc ] dip ] assoc-map ;
|
||||
|
|
@ -0,0 +1,80 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs kernel math namespaces sets make sequences
|
||||
compiler.cfg compiler.cfg.hats
|
||||
compiler.cfg.instructions compiler.cfg.registers
|
||||
compiler.cfg.stacks.height ;
|
||||
IN: compiler.cfg.stacks.local
|
||||
|
||||
! Local stack analysis. We build local peek and replace sets for every basic
|
||||
! block while constructing the CFG.
|
||||
|
||||
SYMBOLS: peek-sets replace-sets ;
|
||||
|
||||
SYMBOL: locs>vregs
|
||||
|
||||
: loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ;
|
||||
|
||||
TUPLE: current-height { d initial: 0 } { r initial: 0 } { emit-d initial: 0 } { emit-r initial: 0 } ;
|
||||
|
||||
SYMBOLS: copies local-peek-set local-replace-set ;
|
||||
|
||||
: record-copy ( dst src -- ) swap copies get set-at ;
|
||||
: resolve-copy ( vreg -- vreg' ) copies get ?at drop ;
|
||||
|
||||
GENERIC: translate-local-loc ( loc -- loc' )
|
||||
M: ds-loc translate-local-loc n>> current-height get d>> - <ds-loc> ;
|
||||
M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
|
||||
|
||||
: emit-height-changes ( -- )
|
||||
! Insert height changes prior to the last instruction
|
||||
building get pop
|
||||
current-height get
|
||||
[ emit-d>> dup 0 = [ drop ] [ ##inc-d ] if ]
|
||||
[ emit-r>> dup 0 = [ drop ] [ ##inc-r ] if ] bi
|
||||
, ;
|
||||
|
||||
! inc-d/inc-r: these emit ##inc-d/##inc-r to change the stack height later
|
||||
: inc-d ( n -- )
|
||||
current-height get
|
||||
[ [ + ] change-emit-d drop ]
|
||||
[ [ + ] change-d drop ]
|
||||
2bi ;
|
||||
|
||||
: inc-r ( n -- )
|
||||
current-height get
|
||||
[ [ + ] change-emit-r drop ]
|
||||
[ [ + ] change-r drop ]
|
||||
2bi ;
|
||||
|
||||
: peek-loc ( loc -- vreg )
|
||||
translate-local-loc
|
||||
[ dup local-replace-set get key? [ drop ] [ local-peek-set get conjoin ] if ]
|
||||
[ loc>vreg [ i ] dip [ record-copy ] [ ##copy ] [ drop ] 2tri ]
|
||||
bi ;
|
||||
|
||||
: replace-loc ( vreg loc -- )
|
||||
translate-local-loc
|
||||
2dup [ resolve-copy ] dip loc>vreg = [ 2drop ] [
|
||||
[ local-replace-set get conjoin ]
|
||||
[ loc>vreg swap ##copy ]
|
||||
bi
|
||||
] if ;
|
||||
|
||||
: begin-local-analysis ( -- )
|
||||
H{ } clone copies set
|
||||
H{ } clone local-peek-set set
|
||||
H{ } clone local-replace-set set
|
||||
current-height get 0 >>emit-d 0 >>emit-r drop
|
||||
current-height get [ d>> ] [ r>> ] bi basic-block get record-stack-heights ;
|
||||
|
||||
: end-local-analysis ( -- )
|
||||
emit-height-changes
|
||||
local-peek-set get basic-block get peek-sets get set-at
|
||||
local-replace-set get basic-block get replace-sets get set-at ;
|
||||
|
||||
: clone-current-height ( -- )
|
||||
current-height [ clone ] change ;
|
||||
|
||||
: peek-set ( bb -- assoc ) peek-sets get at ;
|
||||
: replace-set ( bb -- assoc ) replace-sets get at ;
|
||||
|
|
@ -1,45 +1,76 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math sequences kernel cpu.architecture
|
||||
compiler.cfg.instructions compiler.cfg.registers
|
||||
compiler.cfg.hats ;
|
||||
USING: math sequences kernel namespaces accessors compiler.cfg
|
||||
compiler.cfg.instructions compiler.cfg.registers compiler.cfg.hats
|
||||
compiler.cfg.predecessors compiler.cfg.stacks.local
|
||||
compiler.cfg.stacks.height compiler.cfg.stacks.global
|
||||
compiler.cfg.stacks.finalize ;
|
||||
IN: compiler.cfg.stacks
|
||||
|
||||
: ds-drop ( -- )
|
||||
-1 ##inc-d ;
|
||||
: begin-stack-analysis ( -- )
|
||||
H{ } clone locs>vregs set
|
||||
H{ } clone ds-heights set
|
||||
H{ } clone rs-heights set
|
||||
H{ } clone peek-sets set
|
||||
H{ } clone replace-sets set
|
||||
current-height new current-height set ;
|
||||
|
||||
: ds-pop ( -- vreg )
|
||||
D 0 ^^peek -1 ##inc-d ;
|
||||
: end-stack-analysis ( -- )
|
||||
cfg get
|
||||
compute-predecessors
|
||||
compute-global-sets
|
||||
finalize-stack-shuffling
|
||||
drop ;
|
||||
|
||||
: ds-push ( vreg -- )
|
||||
1 ##inc-d D 0 ##replace ;
|
||||
: ds-drop ( -- ) -1 inc-d ;
|
||||
|
||||
: ds-peek ( -- vreg ) D 0 peek-loc ;
|
||||
|
||||
: ds-pop ( -- vreg ) ds-peek ds-drop ;
|
||||
|
||||
: ds-push ( vreg -- ) 1 inc-d D 0 replace-loc ;
|
||||
|
||||
: ds-load ( n -- vregs )
|
||||
dup 0 =
|
||||
[ drop f ]
|
||||
[ [ <reversed> [ <ds-loc> ^^peek ] map ] [ neg ##inc-d ] bi ] if ;
|
||||
[ [ <reversed> [ <ds-loc> peek-loc ] map ] [ neg inc-d ] bi ] if ;
|
||||
|
||||
: ds-store ( vregs -- )
|
||||
[
|
||||
<reversed>
|
||||
[ length ##inc-d ]
|
||||
[ [ <ds-loc> ##replace ] each-index ] bi
|
||||
[ length inc-d ]
|
||||
[ [ <ds-loc> replace-loc ] each-index ] bi
|
||||
] unless-empty ;
|
||||
|
||||
: rs-drop ( -- ) -1 inc-r ;
|
||||
|
||||
: rs-load ( n -- vregs )
|
||||
dup 0 =
|
||||
[ drop f ]
|
||||
[ [ <reversed> [ <rs-loc> ^^peek ] map ] [ neg ##inc-r ] bi ] if ;
|
||||
[ [ <reversed> [ <rs-loc> peek-loc ] map ] [ neg inc-r ] bi ] if ;
|
||||
|
||||
: rs-store ( vregs -- )
|
||||
[
|
||||
<reversed>
|
||||
[ length ##inc-r ]
|
||||
[ [ <rs-loc> ##replace ] each-index ] bi
|
||||
[ length inc-r ]
|
||||
[ [ <rs-loc> replace-loc ] each-index ] bi
|
||||
] unless-empty ;
|
||||
|
||||
: (2inputs) ( -- vreg1 vreg2 )
|
||||
D 1 peek-loc D 0 peek-loc ;
|
||||
|
||||
: 2inputs ( -- vreg1 vreg2 )
|
||||
D 1 ^^peek D 0 ^^peek -2 ##inc-d ;
|
||||
(2inputs) -2 inc-d ;
|
||||
|
||||
: (3inputs) ( -- vreg1 vreg2 vreg3 )
|
||||
D 2 peek-loc D 1 peek-loc D 0 peek-loc ;
|
||||
|
||||
: 3inputs ( -- vreg1 vreg2 vreg3 )
|
||||
D 2 ^^peek D 1 ^^peek D 0 ^^peek -3 ##inc-d ;
|
||||
(3inputs) -3 inc-d ;
|
||||
|
||||
! adjust-d/adjust-r: these are called when other instructions which
|
||||
! internally adjust the stack height are emitted, such as ##call and
|
||||
! ##alien-invoke
|
||||
: adjust-d ( n -- ) current-height get [ + ] change-d drop ;
|
||||
: adjust-r ( n -- ) current-height get [ + ] change-r drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -20,42 +20,6 @@ IN: compiler.cfg.utilities
|
|||
} cond
|
||||
] [ drop f ] if ;
|
||||
|
||||
: set-basic-block ( basic-block -- )
|
||||
[ basic-block set ] [ instructions>> building set ] bi ;
|
||||
|
||||
: begin-basic-block ( -- )
|
||||
<basic-block> basic-block get [
|
||||
dupd successors>> push
|
||||
] when*
|
||||
set-basic-block ;
|
||||
|
||||
: end-basic-block ( -- )
|
||||
building off
|
||||
basic-block off ;
|
||||
|
||||
: emit-trivial-block ( quot -- )
|
||||
basic-block get instructions>> empty? [ ##branch begin-basic-block ] unless
|
||||
call
|
||||
##branch begin-basic-block ; inline
|
||||
|
||||
: call-height ( #call -- n )
|
||||
[ out-d>> length ] [ in-d>> length ] bi - ;
|
||||
|
||||
: emit-primitive ( node -- )
|
||||
[ [ word>> ] [ call-height ] bi ##call ] emit-trivial-block ;
|
||||
|
||||
: with-branch ( quot -- final-bb )
|
||||
[
|
||||
begin-basic-block
|
||||
call
|
||||
basic-block get dup [ ##branch ] when
|
||||
] with-scope ; inline
|
||||
|
||||
: emit-conditional ( branches -- )
|
||||
end-basic-block
|
||||
begin-basic-block
|
||||
basic-block get '[ [ _ swap successors>> push ] when* ] each ;
|
||||
|
||||
PREDICATE: kill-block < basic-block
|
||||
instructions>> {
|
||||
[ length 2 = ]
|
||||
|
|
|
|||
Loading…
Reference in New Issue