compiler.cfg.stack-analysis: Out with the old, in with the new

db4
Slava Pestov 2009-07-22 00:52:25 -05:00
parent 86df665f78
commit b869e1250c
7 changed files with 5 additions and 614 deletions

View File

@ -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

View File

@ -1 +0,0 @@
Slava Pestov

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -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 ;