compiler.cfg.stack-analysis: Out with the old, in with the new
Slava Pestov
parent
86df665f78
commit
b869e1250c
|
|
@ -4,7 +4,6 @@ USING: kernel sequences accessors combinators namespaces
|
|||
compiler.cfg.tco
|
||||
compiler.cfg.predecessors
|
||||
compiler.cfg.useless-conditionals
|
||||
compiler.cfg.stack-analysis
|
||||
compiler.cfg.dcn
|
||||
compiler.cfg.dominance
|
||||
compiler.cfg.ssa
|
||||
|
|
@ -27,24 +26,19 @@ SYMBOL: check-optimizer?
|
|||
dup check-cfg
|
||||
] when ;
|
||||
|
||||
SYMBOL: new-optimizer?
|
||||
|
||||
: optimize-cfg ( cfg -- cfg' )
|
||||
! Note that compute-predecessors has to be called several times.
|
||||
! The passes that need this document it.
|
||||
[
|
||||
optimize-tail-calls
|
||||
new-optimizer? get [ delete-useless-conditionals ] unless
|
||||
delete-useless-conditionals
|
||||
compute-predecessors
|
||||
new-optimizer? get [ split-branches ] unless
|
||||
new-optimizer? get [
|
||||
deconcatenatize
|
||||
compute-dominance
|
||||
construct-ssa
|
||||
] when
|
||||
split-branches
|
||||
join-blocks
|
||||
compute-predecessors
|
||||
new-optimizer? get [ stack-analysis ] unless
|
||||
deconcatenatize
|
||||
compute-dominance
|
||||
construct-ssa
|
||||
compute-liveness
|
||||
alias-analysis
|
||||
value-numbering
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
Slava Pestov
|
||||
|
|
@ -1,104 +0,0 @@
|
|||
IN: compiler.cfg.stack-analysis.merge.tests
|
||||
USING: compiler.cfg.stack-analysis.merge tools.test arrays accessors
|
||||
compiler.cfg.instructions compiler.cfg.stack-analysis.state
|
||||
compiler.cfg.utilities compiler.cfg compiler.cfg.registers
|
||||
compiler.cfg.debugger cpu.architecture make assocs namespaces
|
||||
sequences kernel classes ;
|
||||
|
||||
[
|
||||
{ D 0 }
|
||||
{ V int-regs 0 V int-regs 1 }
|
||||
] [
|
||||
<state>
|
||||
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 1 set
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
|
||||
|
||||
<state> H{ { D 0 V int-regs 0 } } >>locs>vregs
|
||||
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
|
||||
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
merge-locs locs>vregs>> keys added-phis get values first
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ D 0 }
|
||||
##peek
|
||||
] [
|
||||
<state>
|
||||
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 1 set
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
|
||||
|
||||
<state>
|
||||
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
|
||||
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
[ merge-locs locs>vregs>> keys ] { } make drop
|
||||
1 get added-instructions get at first class
|
||||
] unit-test
|
||||
|
||||
[
|
||||
0 ##inc-d
|
||||
] [
|
||||
<state>
|
||||
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 1 set
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
|
||||
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
|
||||
<state> -1 >>ds-height
|
||||
<state> 2array
|
||||
|
||||
[ merge-ds-heights ds-height>> ] { } make drop
|
||||
1 get added-instructions get at first class
|
||||
] unit-test
|
||||
|
||||
[
|
||||
0
|
||||
{ D 0 }
|
||||
{ 1 1 }
|
||||
] [
|
||||
<state>
|
||||
|
||||
<basic-block> V{ T{ ##branch } } >>instructions
|
||||
<basic-block> V{ T{ ##branch } } >>instructions 2array
|
||||
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
|
||||
[
|
||||
<state> -1 >>ds-height H{ { D 1 V int-regs 0 } } >>locs>vregs
|
||||
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
|
||||
|
||||
[ merge-locs [ ds-height>> ] [ locs>vregs>> keys ] bi ] { } make drop
|
||||
] keep
|
||||
[ instructions>> length ] map
|
||||
] unit-test
|
||||
|
||||
[
|
||||
-1
|
||||
{ D -1 }
|
||||
{ 1 1 }
|
||||
] [
|
||||
<state>
|
||||
|
||||
<basic-block> V{ T{ ##branch } } >>instructions
|
||||
<basic-block> V{ T{ ##branch } } >>instructions 2array
|
||||
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
|
||||
[
|
||||
<state> -1 >>ds-height H{ { D -1 V int-regs 0 } } >>locs>vregs
|
||||
<state> -1 >>ds-height H{ { D -1 V int-regs 1 } } >>locs>vregs 2array
|
||||
|
||||
[ [ merge-ds-heights ] [ merge-locs ] 2bi ] { } make drop
|
||||
[ ds-height>> ] [ locs>vregs>> keys ] bi
|
||||
] keep
|
||||
[ instructions>> length ] map
|
||||
] unit-test
|
||||
|
|
@ -1,117 +0,0 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel assocs sequences accessors fry combinators grouping sets
|
||||
arrays vectors locals namespaces make compiler.cfg compiler.cfg.hats
|
||||
compiler.cfg.instructions compiler.cfg.stack-analysis.state
|
||||
compiler.cfg.registers compiler.cfg.utilities cpu.architecture ;
|
||||
IN: compiler.cfg.stack-analysis.merge
|
||||
|
||||
: initial-state ( bb states -- state ) 2drop <state> ;
|
||||
|
||||
: single-predecessor ( bb states -- state ) nip first clone ;
|
||||
|
||||
: save-ds-height ( n -- )
|
||||
dup 0 = [ drop ] [ ##inc-d ] if ;
|
||||
|
||||
: merge-ds-heights ( state predecessors states -- state )
|
||||
[ ds-height>> ] map dup all-equal?
|
||||
[ nip first >>ds-height ]
|
||||
[ [ '[ _ save-ds-height ] add-instructions ] 2each ] if ;
|
||||
|
||||
: save-rs-height ( n -- )
|
||||
dup 0 = [ drop ] [ ##inc-r ] if ;
|
||||
|
||||
: merge-rs-heights ( state predecessors states -- state )
|
||||
[ rs-height>> ] map dup all-equal?
|
||||
[ nip first >>rs-height ]
|
||||
[ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ;
|
||||
|
||||
: assoc-map-keys ( assoc quot -- assoc' )
|
||||
'[ _ dip ] assoc-map ; inline
|
||||
|
||||
: translate-locs ( assoc state -- assoc' )
|
||||
'[ _ translate-loc ] assoc-map-keys ;
|
||||
|
||||
: untranslate-locs ( assoc state -- assoc' )
|
||||
'[ _ untranslate-loc ] assoc-map-keys ;
|
||||
|
||||
: collect-locs ( loc-maps states -- assoc )
|
||||
! assoc maps locs to sequences
|
||||
[ untranslate-locs ] 2map
|
||||
[ [ keys ] map concat prune ] keep
|
||||
'[ dup _ [ at ] with map ] H{ } map>assoc ;
|
||||
|
||||
: insert-peek ( predecessor loc state -- vreg )
|
||||
'[ _ _ translate-loc ^^peek ] add-instructions ;
|
||||
|
||||
SYMBOL: added-phis
|
||||
|
||||
: add-phi-later ( inputs -- vreg )
|
||||
[ int-regs next-vreg dup ] dip 2array added-phis get push ;
|
||||
|
||||
: merge-loc ( predecessors vregs loc state -- vreg )
|
||||
! Insert a ##phi in the current block where the input
|
||||
! is the vreg storing loc from each predecessor block
|
||||
'[ [ ] [ _ _ insert-peek ] ?if ] 2map
|
||||
dup all-equal? [ first ] [ add-phi-later ] if ;
|
||||
|
||||
:: merge-locs ( state predecessors states -- state )
|
||||
states [ locs>vregs>> ] map states collect-locs
|
||||
[| key value |
|
||||
key
|
||||
predecessors value key state merge-loc
|
||||
] assoc-map
|
||||
state translate-locs
|
||||
state (>>locs>vregs)
|
||||
state ;
|
||||
|
||||
: merge-actual-loc ( vregs -- vreg/f )
|
||||
dup all-equal? [ first ] [ drop f ] if ;
|
||||
|
||||
:: merge-actual-locs ( state states -- state )
|
||||
states [ actual-locs>vregs>> ] map states collect-locs
|
||||
[ merge-actual-loc ] assoc-map [ nip ] assoc-filter
|
||||
state translate-locs
|
||||
state (>>actual-locs>vregs)
|
||||
state ;
|
||||
|
||||
: merge-changed-locs ( state states -- state )
|
||||
[ [ changed-locs>> ] keep untranslate-locs ] map assoc-combine
|
||||
over translate-locs
|
||||
>>changed-locs ;
|
||||
|
||||
:: insert-phis ( bb -- )
|
||||
bb predecessors>> :> predecessors
|
||||
[
|
||||
added-phis get [| dst inputs |
|
||||
dst predecessors inputs zip ##phi
|
||||
] assoc-each
|
||||
] V{ } make bb instructions>> over push-all
|
||||
bb (>>instructions) ;
|
||||
|
||||
:: multiple-predecessors ( bb states -- state )
|
||||
states [ not ] any? [
|
||||
<state>
|
||||
bb add-to-work-list
|
||||
] [
|
||||
[
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
bb predecessors>> :> predecessors
|
||||
state new
|
||||
predecessors states merge-ds-heights
|
||||
predecessors states merge-rs-heights
|
||||
predecessors states merge-locs
|
||||
states merge-actual-locs
|
||||
states merge-changed-locs
|
||||
bb insert-basic-blocks
|
||||
bb insert-phis
|
||||
] with-scope
|
||||
] if ;
|
||||
|
||||
: merge-states ( bb states -- state )
|
||||
dup length {
|
||||
{ 0 [ initial-state ] }
|
||||
{ 1 [ single-predecessor ] }
|
||||
[ drop multiple-predecessors ]
|
||||
} case ;
|
||||
|
|
@ -1,204 +0,0 @@
|
|||
USING: prettyprint compiler.cfg.debugger compiler.cfg.linearization
|
||||
compiler.cfg.predecessors compiler.cfg.stack-analysis
|
||||
compiler.cfg.instructions sequences kernel tools.test accessors
|
||||
sequences.private alien math combinators.private compiler.cfg
|
||||
compiler.cfg.checker compiler.cfg.rpo
|
||||
compiler.cfg.dce compiler.cfg.registers
|
||||
sets namespaces arrays cpu.architecture ;
|
||||
IN: compiler.cfg.stack-analysis.tests
|
||||
|
||||
! Fundamental invariant: a basic block should not load or store a value more than once
|
||||
: test-stack-analysis ( quot -- cfg )
|
||||
dup cfg? [ test-cfg first ] unless
|
||||
compute-predecessors
|
||||
stack-analysis
|
||||
dup check-cfg ;
|
||||
|
||||
: linearize ( cfg -- mr )
|
||||
flatten-cfg instructions>> ;
|
||||
|
||||
[ ] [ [ ] test-stack-analysis drop ] unit-test
|
||||
|
||||
! Only peek once
|
||||
[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize [ ##peek? ] count ] unit-test
|
||||
|
||||
! Redundant replace is redundant
|
||||
[ f ] [ [ dup drop ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
|
||||
[ f ] [ [ swap swap ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
|
||||
|
||||
! Replace required here
|
||||
[ t ] [ [ dup ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
|
||||
[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
|
||||
|
||||
! Only one replace, at the end
|
||||
[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize [ ##replace? ] count ] unit-test
|
||||
|
||||
! Do we support the full language?
|
||||
[ ] [ [ { [ ] [ ] } dispatch ] test-stack-analysis drop ] unit-test
|
||||
[ ] [ [ { [ ] [ ] } dispatch dup ] test-stack-analysis drop ] unit-test
|
||||
[ ] [
|
||||
[ "int" { "int" "int" } "cdecl" [ + ] alien-callback ]
|
||||
test-cfg second test-stack-analysis drop
|
||||
] unit-test
|
||||
|
||||
! Test loops
|
||||
[ ] [ [ [ t ] loop ] test-stack-analysis drop ] unit-test
|
||||
[ ] [ [ [ dup ] loop ] test-stack-analysis drop ] unit-test
|
||||
|
||||
! Make sure that peeks are inserted in the right place
|
||||
[ ] [ [ [ drop 1 ] when ] test-stack-analysis drop ] unit-test
|
||||
|
||||
! This should be a total no-op
|
||||
[ f ] [ [ [ ] dip ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
|
||||
|
||||
! Don't insert inc-d/inc-r; that's wrong!
|
||||
[ 1 ] [ [ dup ] test-stack-analysis linearize [ ##inc-d? ] count ] unit-test
|
||||
|
||||
! Bug in height tracking
|
||||
[ ] [ [ dup [ ] [ reverse ] if ] test-stack-analysis drop ] unit-test
|
||||
[ ] [ [ dup [ ] [ dup reverse drop ] if ] test-stack-analysis drop ] unit-test
|
||||
[ ] [ [ [ drop dup 4.0 > ] find-last-integer ] test-stack-analysis drop ] unit-test
|
||||
|
||||
! Bugs with code that throws
|
||||
[ ] [ [ [ "Oops" throw ] unless ] test-stack-analysis drop ] unit-test
|
||||
[ ] [ [ [ ] (( -- * )) call-effect-unsafe ] test-stack-analysis drop ] unit-test
|
||||
[ ] [ [ dup [ "Oops" throw ] when dup ] test-stack-analysis drop ] unit-test
|
||||
[ ] [ [ B{ 1 2 3 4 } over [ "Oops" throw ] when swap ] test-stack-analysis drop ] unit-test
|
||||
|
||||
! Make sure the replace stores a value with the right height
|
||||
[ ] [
|
||||
[ [ . ] [ 2drop 1 ] if ] test-stack-analysis eliminate-dead-code linearize
|
||||
[ ##replace? ] filter [ length 1 assert= ] [ first loc>> D 0 assert= ] bi
|
||||
] unit-test
|
||||
|
||||
! translate-loc was the wrong way round
|
||||
[ ] [
|
||||
[ 1 2 rot ] test-stack-analysis eliminate-dead-code linearize
|
||||
[ [ ##load-immediate? ] count 2 assert= ]
|
||||
[ [ ##peek? ] count 1 assert= ]
|
||||
[ [ ##replace? ] count 3 assert= ]
|
||||
tri
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[ 1 2 ? ] test-stack-analysis eliminate-dead-code linearize
|
||||
[ [ ##load-immediate? ] count 2 assert= ]
|
||||
[ [ ##peek? ] count 1 assert= ]
|
||||
[ [ ##replace? ] count 1 assert= ]
|
||||
tri
|
||||
] unit-test
|
||||
|
||||
! Sync before a back-edge, not after
|
||||
! ##peeks should be inserted before a ##loop-entry
|
||||
! Don't optimize out the constants
|
||||
[ t ] [
|
||||
[ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
|
||||
[ ##load-immediate? ] any?
|
||||
] unit-test
|
||||
|
||||
! Correct height tracking
|
||||
[ t ] [
|
||||
[ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
|
||||
reverse-post-order 4 swap nth
|
||||
instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi*
|
||||
2array { D 1 D 0 } set=
|
||||
] unit-test
|
||||
|
||||
[ D 1 ] [
|
||||
V{ T{ ##branch } } 0 test-bb
|
||||
|
||||
V{ T{ ##peek f V int-regs 0 D 2 } T{ ##branch } } 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 1 D 2 }
|
||||
T{ ##inc-d f -1 }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{ T{ ##call f \ + -1 } T{ ##branch } } 3 test-bb
|
||||
|
||||
V{ T{ ##return } } 4 test-bb
|
||||
|
||||
test-diamond
|
||||
|
||||
cfg new 0 get >>entry
|
||||
compute-predecessors
|
||||
stack-analysis
|
||||
drop
|
||||
|
||||
3 get successors>> first instructions>> first loc>>
|
||||
] unit-test
|
||||
|
||||
! Do inserted ##peeks reference the correct stack location if
|
||||
! an ##inc-d/r was also inserted?
|
||||
[ D 0 ] [
|
||||
V{ T{ ##branch } } 0 test-bb
|
||||
|
||||
V{ T{ ##branch } } 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 1 D 0 }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##call f \ + -1 }
|
||||
T{ ##inc-d f 1 }
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{ T{ ##return } } 4 test-bb
|
||||
|
||||
test-diamond
|
||||
|
||||
cfg new 0 get >>entry
|
||||
compute-predecessors
|
||||
stack-analysis
|
||||
drop
|
||||
|
||||
3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
|
||||
] unit-test
|
||||
|
||||
! Missing ##replace
|
||||
[ t ] [
|
||||
[ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
|
||||
reverse-post-order last
|
||||
instructions>> [ ##replace? ] filter [ loc>> ] map
|
||||
{ D 0 D 1 D 2 } set=
|
||||
] unit-test
|
||||
|
||||
! Inserted ##peeks reference the wrong stack location
|
||||
[ t ] [
|
||||
[ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
|
||||
eliminate-dead-code reverse-post-order 4 swap nth
|
||||
instructions>> [ ##peek? ] filter [ loc>> ] map
|
||||
{ D 0 D 1 } set=
|
||||
] unit-test
|
||||
|
||||
[ D 0 ] [
|
||||
V{ T{ ##branch } } 0 test-bb
|
||||
|
||||
V{ T{ ##branch } } 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 1 D 0 }
|
||||
T{ ##inc-d f 1 }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##inc-d f 1 }
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{ T{ ##return } } 4 test-bb
|
||||
|
||||
test-diamond
|
||||
|
||||
cfg new 0 get >>entry
|
||||
compute-predecessors
|
||||
stack-analysis
|
||||
drop
|
||||
|
||||
3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
|
||||
] unit-test
|
||||
|
|
@ -1,124 +0,0 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs kernel namespaces math sequences fry grouping
|
||||
sets make combinators dlists deques
|
||||
compiler.cfg
|
||||
compiler.cfg.copy-prop
|
||||
compiler.cfg.def-use
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.stack-analysis.state
|
||||
compiler.cfg.stack-analysis.merge
|
||||
compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.stack-analysis
|
||||
|
||||
SYMBOL: global-optimization?
|
||||
|
||||
: redundant-replace? ( vreg loc -- ? )
|
||||
dup state get untranslate-loc n>> 0 <
|
||||
[ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
|
||||
|
||||
: save-changed-locs ( state -- )
|
||||
[ changed-locs>> keys ] [ locs>vregs>> ] bi '[
|
||||
dup _ at swap 2dup redundant-replace?
|
||||
[ 2drop ] [ state get untranslate-loc ##replace ] if
|
||||
] each ;
|
||||
|
||||
: sync-state ( -- )
|
||||
state get {
|
||||
[ ds-height>> save-ds-height ]
|
||||
[ rs-height>> save-rs-height ]
|
||||
[ save-changed-locs ]
|
||||
[ clear-state ]
|
||||
} cleave ;
|
||||
|
||||
! Abstract interpretation
|
||||
GENERIC: visit ( insn -- )
|
||||
|
||||
M: ##inc-d visit
|
||||
n>> state get [ + ] change-ds-height drop ;
|
||||
|
||||
M: ##inc-r visit
|
||||
n>> state get [ + ] change-rs-height drop ;
|
||||
|
||||
! Instructions which don't have any effect on the stack
|
||||
UNION: neutral-insn
|
||||
##effect
|
||||
##flushable
|
||||
##no-tco ;
|
||||
|
||||
M: neutral-insn visit , ;
|
||||
|
||||
UNION: sync-if-back-edge
|
||||
##branch
|
||||
##conditional-branch
|
||||
##compare-imm-branch
|
||||
##dispatch
|
||||
##loop-entry
|
||||
##fixnum-overflow ;
|
||||
|
||||
: sync-state? ( -- ? )
|
||||
basic-block get successors>>
|
||||
[ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? ;
|
||||
|
||||
M: sync-if-back-edge visit
|
||||
global-optimization? get [ sync-state? [ sync-state ] when ] unless
|
||||
, ;
|
||||
|
||||
: eliminate-peek ( dst src -- )
|
||||
! the requested stack location is already in 'src'
|
||||
[ ##copy ] [ swap copies get set-at ] 2bi ;
|
||||
|
||||
M: ##peek visit
|
||||
[ dst>> ] [ loc>> state get translate-loc ] bi dup loc>vreg
|
||||
[ eliminate-peek ] [ [ record-peek ] [ ##peek ] 2bi ] ?if ;
|
||||
|
||||
M: ##replace visit
|
||||
[ src>> resolve ] [ loc>> state get translate-loc ] bi
|
||||
record-replace ;
|
||||
|
||||
M: ##copy visit
|
||||
[ call-next-method ] [ record-copy ] bi ;
|
||||
|
||||
M: ##jump visit sync-state , ;
|
||||
|
||||
M: ##return visit sync-state , ;
|
||||
|
||||
M: ##callback-return visit sync-state , ;
|
||||
|
||||
M: kill-vreg-insn visit sync-state , ;
|
||||
|
||||
! Maps basic-blocks to states
|
||||
SYMBOL: state-out
|
||||
|
||||
: block-in-state ( bb -- states )
|
||||
dup predecessors>> state-out get '[ _ at ] map merge-states ;
|
||||
|
||||
: set-block-out-state ( state bb -- )
|
||||
[ clone ] dip state-out get set-at ;
|
||||
|
||||
: visit-block ( bb -- )
|
||||
! block-in-state may add phi nodes at the start of the basic block
|
||||
! so we wrap the whole thing with a 'make'
|
||||
[
|
||||
dup basic-block set
|
||||
dup block-in-state
|
||||
state [
|
||||
[ instructions>> [ visit ] each ]
|
||||
[ [ state get ] dip set-block-out-state ]
|
||||
[ ]
|
||||
tri
|
||||
] with-variable
|
||||
] V{ } make >>instructions drop ;
|
||||
|
||||
: stack-analysis ( cfg -- cfg' )
|
||||
[
|
||||
<hashed-dlist> work-list set
|
||||
H{ } clone copies set
|
||||
H{ } clone state-out set
|
||||
dup [ visit-block ] each-basic-block
|
||||
global-optimization? get [ work-list get [ visit-block ] slurp-deque ] when
|
||||
cfg-changed
|
||||
] with-scope ;
|
||||
|
|
@ -1,53 +0,0 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors namespaces assocs sets math deques
|
||||
compiler.cfg.registers ;
|
||||
IN: compiler.cfg.stack-analysis.state
|
||||
|
||||
TUPLE: state
|
||||
locs>vregs actual-locs>vregs changed-locs
|
||||
{ ds-height integer }
|
||||
{ rs-height integer }
|
||||
poisoned? ;
|
||||
|
||||
: <state> ( -- state )
|
||||
state new
|
||||
H{ } clone >>locs>vregs
|
||||
H{ } clone >>actual-locs>vregs
|
||||
H{ } clone >>changed-locs
|
||||
0 >>ds-height
|
||||
0 >>rs-height ;
|
||||
|
||||
M: state clone
|
||||
call-next-method
|
||||
[ clone ] change-locs>vregs
|
||||
[ clone ] change-actual-locs>vregs
|
||||
[ clone ] change-changed-locs ;
|
||||
|
||||
: loc>vreg ( loc -- vreg ) state get locs>vregs>> at ;
|
||||
|
||||
: record-peek ( dst loc -- )
|
||||
state get [ locs>vregs>> set-at ] [ actual-locs>vregs>> set-at ] 3bi ;
|
||||
|
||||
: changed-loc ( loc -- )
|
||||
state get changed-locs>> conjoin ;
|
||||
|
||||
: record-replace ( src loc -- )
|
||||
dup changed-loc state get locs>vregs>> set-at ;
|
||||
|
||||
: clear-state ( state -- )
|
||||
0 >>ds-height 0 >>rs-height
|
||||
[ locs>vregs>> ] [ actual-locs>vregs>> ] [ changed-locs>> ] tri
|
||||
[ clear-assoc ] tri@ ;
|
||||
|
||||
GENERIC# translate-loc 1 ( loc state -- loc' )
|
||||
M: ds-loc translate-loc [ n>> ] [ ds-height>> ] bi* - <ds-loc> ;
|
||||
M: rs-loc translate-loc [ n>> ] [ rs-height>> ] bi* - <rs-loc> ;
|
||||
|
||||
GENERIC# untranslate-loc 1 ( loc state -- loc' )
|
||||
M: ds-loc untranslate-loc [ n>> ] [ ds-height>> ] bi* + <ds-loc> ;
|
||||
M: rs-loc untranslate-loc [ n>> ] [ rs-height>> ] bi* + <rs-loc> ;
|
||||
|
||||
SYMBOL: work-list
|
||||
|
||||
: add-to-work-list ( bb -- ) work-list get push-front ;
|
||||
Loading…
Reference in New Issue