compiler.cfg.dcn: starting work on deconcatenatization pass to replace compiler.cfg.stack-analysis
Slava Pestov
parent
a213db05db
commit
ec1407bdae
|
|
@ -0,0 +1,394 @@
|
|||
IN: compiler.cfg.dcn.tests
|
||||
USING: tools.test kernel accessors namespaces assocs
|
||||
cpu.architecture vectors sequences
|
||||
compiler.cfg
|
||||
compiler.cfg.debugger
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.predecessors
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.dcn.height
|
||||
compiler.cfg.dcn.local
|
||||
compiler.cfg.dcn.local.private
|
||||
compiler.cfg.dcn.global
|
||||
compiler.cfg.dcn.global.private
|
||||
compiler.cfg.dcn.rewrite ;
|
||||
|
||||
: test-local-dcn ( insns -- insns' )
|
||||
<basic-block> swap >>instructions
|
||||
[ local-analysis ] keep
|
||||
instructions>> ;
|
||||
|
||||
[
|
||||
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 }
|
||||
}
|
||||
] [
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##peek f V int-regs 1 D 0 }
|
||||
T{ ##peek f V int-regs 2 D 1 }
|
||||
T{ ##peek f V int-regs 3 D 1 }
|
||||
T{ ##replace f V int-regs 2 D 1 }
|
||||
T{ ##replace f V int-regs 4 D 2 }
|
||||
T{ ##peek f V int-regs 5 D 2 }
|
||||
T{ ##replace f V int-regs 5 D 2 }
|
||||
T{ ##replace f V int-regs 6 D 0 }
|
||||
} 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
|
||||
[ compute-heights ]
|
||||
[ compute-local-sets ]
|
||||
[ compute-global-sets ] tri ;
|
||||
|
||||
V{ T{ ##return } } 0 test-bb
|
||||
|
||||
[ ] [ test-global-dcn ] unit-test
|
||||
|
||||
V{
|
||||
T{ ##prologue }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##replace f V int-regs 1 D 1 }
|
||||
} 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 1 } ] [ 1 get 2 get inserting-replaces ] unit-test
|
||||
|
||||
V{
|
||||
T{ ##prologue }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
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{ ##replace f V int-regs 2 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 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
|
||||
|
||||
[ { 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 } ] [ 2 get 4 get inserting-peeks ] unit-test
|
||||
[ { } ] [ 2 get 4 get inserting-replaces ] unit-test
|
||||
[ { } ] [ 4 get 5 get inserting-peeks ] unit-test
|
||||
[ { D 0 } ] [ 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{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##replace f V int-regs 2 D 1 }
|
||||
T{ ##peek f V int-regs 4 D 2 }
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##replace f V int-regs 3 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 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 1 } ] [ 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 0 }
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##call f drop }
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 1 D 0 }
|
||||
T{ ##return }
|
||||
} 4 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
|
||||
|
||||
[ ] [ test-global-dcn ] unit-test
|
||||
|
||||
[ t ] [ D 0 2 get avail-out key? ] unit-test
|
||||
[ f ] [ D 0 3 get peek-out key? ] unit-test
|
||||
[ f ] [ D 0 3 get avail-out key? ] unit-test
|
||||
[ f ] [ D 0 4 get avail-in 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
|
||||
[ { } ] [ 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{ ##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{ ##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
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: ;
|
||||
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.
|
||||
|
|
@ -0,0 +1,202 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs deques dlists fry kernel namespaces sequences
|
||||
combinators combinators.short-circuit compiler.cfg.instructions
|
||||
compiler.cfg.dcn.local compiler.cfg.rpo compiler.cfg ;
|
||||
IN: compiler.cfg.dcn.global
|
||||
|
||||
<PRIVATE
|
||||
|
||||
PREDICATE: kill-block < basic-block
|
||||
instructions>> {
|
||||
[ length 2 = ]
|
||||
[ first kill-vreg-insn? ]
|
||||
} 1&& ;
|
||||
|
||||
: assoc-refine ( seq -- assoc )
|
||||
[ f ] [ [ ] [ assoc-intersect ] map-reduce ] if-empty ;
|
||||
|
||||
SYMBOL: work-list
|
||||
|
||||
: add-to-work-list ( basic-blocks -- )
|
||||
work-list get '[ _ push-front ] each ;
|
||||
|
||||
! Peek analysis. Peek-in is the set of all locations anticipated at
|
||||
! the start of a basic block.
|
||||
SYMBOLS: peek-ins peek-outs ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: peek-in ( bb -- assoc ) peek-ins get at ;
|
||||
: peek-out ( bb -- assoc ) peek-outs get at ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC: compute-peek-in ( bb -- assoc )
|
||||
|
||||
M: basic-block compute-peek-in
|
||||
[ [ peek-out ] [ replace ] bi assoc-diff ] [ peek ] bi assoc-union ;
|
||||
|
||||
M: kill-block compute-peek-in drop f ;
|
||||
|
||||
: update-peek-in ( bb -- ? )
|
||||
[ compute-peek-in ] keep peek-ins get maybe-set-at ;
|
||||
|
||||
GENERIC: compute-peek-out ( bb -- assoc )
|
||||
|
||||
M: basic-block compute-peek-out
|
||||
successors>> peek-ins get '[ _ at ] map assoc-refine ;
|
||||
|
||||
M: kill-block compute-peek-out drop f ;
|
||||
|
||||
: update-peek-out ( bb -- ? )
|
||||
[ compute-peek-out ] keep peek-outs get maybe-set-at ;
|
||||
|
||||
: peek-step ( bb -- )
|
||||
dup update-peek-out [
|
||||
dup update-peek-in
|
||||
[ predecessors>> add-to-work-list ] [ drop ] if
|
||||
] [ drop ] if ;
|
||||
|
||||
: compute-peek-sets ( cfg -- )
|
||||
H{ } clone peek-ins set
|
||||
H{ } clone peek-outs set
|
||||
post-order add-to-work-list work-list get [ peek-step ] slurp-deque ;
|
||||
|
||||
! Replace analysis. Replace-in is the set of all locations which
|
||||
! will be overwritten at some point after the start of a basic block.
|
||||
SYMBOLS: replace-ins replace-outs ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: replace-in ( bb -- assoc ) replace-ins get at ;
|
||||
: replace-out ( bb -- assoc ) replace-outs get at ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC: compute-replace-in ( bb -- assoc )
|
||||
|
||||
M: basic-block compute-replace-in
|
||||
predecessors>> replace-outs get '[ _ at ] map assoc-refine ;
|
||||
|
||||
M: kill-block compute-replace-in drop f ;
|
||||
|
||||
: update-replace-in ( bb -- ? )
|
||||
[ compute-replace-in ] keep replace-ins get maybe-set-at ;
|
||||
|
||||
GENERIC: compute-replace-out ( bb -- assoc )
|
||||
|
||||
M: basic-block compute-replace-out
|
||||
[ replace-in ] [ replace ] bi assoc-union ;
|
||||
|
||||
M: kill-block compute-replace-out drop f ;
|
||||
|
||||
: update-replace-out ( bb -- ? )
|
||||
[ compute-replace-out ] keep replace-outs get maybe-set-at ;
|
||||
|
||||
: replace-step ( bb -- )
|
||||
dup update-replace-in [
|
||||
dup update-replace-out
|
||||
[ successors>> add-to-work-list ] [ drop ] if
|
||||
] [ drop ] if ;
|
||||
|
||||
: compute-replace-sets ( cfg -- )
|
||||
H{ } clone replace-ins set
|
||||
H{ } clone replace-outs set
|
||||
reverse-post-order add-to-work-list work-list get [ replace-step ] slurp-deque ;
|
||||
|
||||
! Availability analysis. Avail-out is the set of all locations
|
||||
! in registers at the end of a basic block.
|
||||
SYMBOLS: avail-ins avail-outs ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: avail-in ( bb -- assoc ) avail-ins get at ;
|
||||
: avail-out ( bb -- assoc ) avail-outs get at ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC: compute-avail-in ( bb -- assoc )
|
||||
|
||||
M: basic-block compute-avail-in
|
||||
predecessors>> avail-outs get '[ _ at ] map assoc-refine ;
|
||||
|
||||
M: kill-block compute-avail-in drop f ;
|
||||
|
||||
: update-avail-in ( bb -- ? )
|
||||
[ compute-avail-in ] keep avail-ins get maybe-set-at ;
|
||||
|
||||
GENERIC: compute-avail-out ( bb -- assoc )
|
||||
|
||||
M: basic-block compute-avail-out
|
||||
[ avail-in ] [ peek ] [ replace ] tri assoc-union assoc-union ;
|
||||
|
||||
M: kill-block compute-avail-out drop f ;
|
||||
|
||||
: update-avail-out ( bb -- ? )
|
||||
[ compute-avail-out ] keep avail-outs get maybe-set-at ;
|
||||
|
||||
: avail-step ( bb -- )
|
||||
dup update-avail-in [
|
||||
dup update-avail-out
|
||||
[ successors>> add-to-work-list ] [ drop ] if
|
||||
] [ drop ] if ;
|
||||
|
||||
: compute-avail-sets ( cfg -- )
|
||||
H{ } clone avail-ins set
|
||||
H{ } clone avail-outs set
|
||||
reverse-post-order add-to-work-list work-list get [ avail-step ] slurp-deque ;
|
||||
|
||||
! Kill analysis. Kill-in is the set of all locations
|
||||
! which are going to be overwritten.
|
||||
SYMBOLS: kill-ins kill-outs ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: kill-in ( bb -- assoc ) kill-ins get at ;
|
||||
: kill-out ( bb -- assoc ) kill-outs get at ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC: compute-kill-in ( bb -- assoc )
|
||||
|
||||
M: basic-block compute-kill-in
|
||||
[ kill-out ] [ replace ] bi assoc-union ;
|
||||
|
||||
M: kill-block compute-kill-in drop f ;
|
||||
|
||||
: update-kill-in ( bb -- ? )
|
||||
[ compute-kill-in ] keep kill-ins get maybe-set-at ;
|
||||
|
||||
GENERIC: compute-kill-out ( bb -- assoc )
|
||||
|
||||
M: basic-block compute-kill-out
|
||||
successors>> kill-ins get '[ _ at ] map assoc-refine ;
|
||||
|
||||
M: kill-block compute-kill-out drop f ;
|
||||
|
||||
: update-kill-out ( bb -- ? )
|
||||
[ compute-kill-out ] keep kill-outs get maybe-set-at ;
|
||||
|
||||
: kill-step ( bb -- )
|
||||
dup update-kill-out [
|
||||
dup update-kill-in
|
||||
[ predecessors>> add-to-work-list ] [ drop ] if
|
||||
] [ drop ] if ;
|
||||
|
||||
: compute-kill-sets ( cfg -- )
|
||||
H{ } clone kill-ins set
|
||||
H{ } clone kill-outs set
|
||||
post-order add-to-work-list work-list get [ kill-step ] slurp-deque ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! Main word
|
||||
: compute-global-sets ( cfg -- )
|
||||
<hashed-dlist> work-list set
|
||||
{
|
||||
[ compute-peek-sets ]
|
||||
[ compute-replace-sets ]
|
||||
[ compute-avail-sets ]
|
||||
[ compute-kill-sets ]
|
||||
} cleave ;
|
||||
|
|
@ -0,0 +1,82 @@
|
|||
! 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>> ;
|
||||
|
||||
! XXX
|
||||
! M: ##call ds-height-change height>> ;
|
||||
|
||||
M: ##call ds-height-change drop 0 ;
|
||||
|
||||
M: ##alien-invoke ds-height-change height>> ;
|
||||
|
||||
M: ##alien-indirect ds-height-change 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-in-loc 1 ( loc bb -- loc' )
|
||||
|
||||
M: ds-loc translate-in-loc n>> in-ds-heights get at + <ds-loc> ;
|
||||
M: rs-loc translate-in-loc n>> in-rs-heights get at + <ds-loc> ;
|
||||
|
||||
GENERIC# translate-out-loc 1 ( loc bb -- loc' )
|
||||
|
||||
M: ds-loc translate-out-loc n>> out-ds-heights get at + <ds-loc> ;
|
||||
M: rs-loc translate-out-loc n>> out-rs-heights get at + <ds-loc> ;
|
||||
|
||||
: translate-in-set ( assoc bb -- assoc' )
|
||||
'[ [ _ translate-in-loc ] dip ] assoc-map ;
|
||||
|
||||
: translate-out-set ( assoc bb -- assoc' )
|
||||
'[ [ _ translate-out-loc ] dip ] assoc-map ;
|
||||
|
|
@ -0,0 +1,73 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs kernel make
|
||||
namespaces sequences
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.instructions ;
|
||||
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 ;
|
||||
|
||||
GENERIC: visit ( insn -- )
|
||||
|
||||
M: insn visit , ;
|
||||
|
||||
M: ##peek visit
|
||||
! If location is in a register already, copy existing
|
||||
! register to destination. Otherwise, associate the
|
||||
! location with the register.
|
||||
[ dst>> ] [ 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>> ] 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 ;
|
||||
|
||||
: 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).
|
||||
H{ } clone copies set
|
||||
H{ } clone reads-locations set
|
||||
H{ } clone writes-locations set
|
||||
[ [ [ visit ] each ] V{ } make ] change-instructions drop ;
|
||||
|
||||
SYMBOLS: peeks replaces ;
|
||||
|
||||
: visit-block ( bb -- )
|
||||
[ local-analysis ]
|
||||
[ [ reads-locations get ] dip peeks get set-at ]
|
||||
[ [ writes-locations get ] dip 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 ;
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces assocs kernel compiler.cfg.dcn.global ;
|
||||
IN: compiler.cfg.dcn.rewrite
|
||||
|
||||
: inserting-peeks ( from to -- seq )
|
||||
peek-in swap [ peek-out ] [ avail-out ] bi assoc-union assoc-diff keys ;
|
||||
|
||||
: inserting-replaces ( from to -- seq )
|
||||
[ replace-out ] [ kill-in ] bi* assoc-diff keys ;
|
||||
Loading…
Reference in New Issue