compiler.cfg.stack-analysis: make it pass more tests
Slava Pestov
parent
8b022f926c
commit
7ea4e255fb
|
|
@ -1,37 +1,51 @@
|
|||
USING: compiler.cfg.debugger compiler.cfg.linearization
|
||||
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.checker compiler.cfg.height compiler.cfg.rpo
|
||||
compiler.cfg.dce compiler.cfg.registers sets ;
|
||||
IN: compiler.cfg.stack-analysis.tests
|
||||
|
||||
[ f ] [ 1 2 H{ { 2 1 } } maybe-set-at ] unit-test
|
||||
[ t ] [ 1 3 H{ { 2 1 } } clone maybe-set-at ] unit-test
|
||||
[ t ] [ 3 2 H{ { 2 1 } } clone maybe-set-at ] unit-test
|
||||
|
||||
: linearize ( cfg -- seq )
|
||||
build-mr instructions>> ;
|
||||
! Fundamental invariant: a basic block should not load or store a value more than once
|
||||
: check-for-redundant-ops ( rpo -- )
|
||||
[
|
||||
instructions>>
|
||||
[
|
||||
[ ##peek? ] filter [ loc>> ] map duplicates empty?
|
||||
[ "Redundant peeks" throw ] unless
|
||||
] [
|
||||
[ ##replace? ] filter [ loc>> ] map duplicates empty?
|
||||
[ "Redundant replaces" throw ] unless
|
||||
] bi
|
||||
] each ;
|
||||
|
||||
: test-stack-analysis ( quot -- mr )
|
||||
dup cfg? [ test-cfg first ] unless
|
||||
compute-predecessors optimize-stack
|
||||
dup check-cfg ;
|
||||
compute-predecessors
|
||||
entry>> reverse-post-order
|
||||
optimize-stack
|
||||
dup [ [ normalize-height ] change-instructions drop ] each
|
||||
dup check-rpo dup check-for-redundant-ops ;
|
||||
|
||||
[ ] [ [ ] test-stack-analysis drop ] unit-test
|
||||
|
||||
! Only peek once
|
||||
[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize [ ##peek? ] count ] unit-test
|
||||
[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize-basic-blocks [ ##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
|
||||
[ f ] [ [ dup drop ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test
|
||||
[ f ] [ [ swap swap ] test-stack-analysis linearize-basic-blocks [ ##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
|
||||
[ t ] [ [ dup ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test
|
||||
[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test
|
||||
|
||||
! Only one replace, at the end
|
||||
[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize [ ##replace? ] count ] unit-test
|
||||
[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize-basic-blocks [ ##replace? ] count ] unit-test
|
||||
|
||||
! Do we support the full language?
|
||||
[ ] [ [ { [ ] [ ] } dispatch ] test-stack-analysis drop ] unit-test
|
||||
|
|
@ -49,10 +63,10 @@ IN: compiler.cfg.stack-analysis.tests
|
|||
[ ] [ [ [ 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
|
||||
[ f ] [ [ [ ] dip ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test
|
||||
|
||||
! Don't insert inc-d/inc-r; that's wrong!
|
||||
[ 2 ] [ [ dup ] test-stack-analysis linearize [ ##inc-d? ] count ] unit-test
|
||||
[ 1 ] [ [ dup ] test-stack-analysis linearize-basic-blocks [ ##inc-d? ] count ] unit-test
|
||||
|
||||
! Bug in height tracking
|
||||
[ ] [ [ dup [ ] [ reverse ] if ] test-stack-analysis drop ] unit-test
|
||||
|
|
@ -63,4 +77,27 @@ IN: compiler.cfg.stack-analysis.tests
|
|||
[ ] [ [ [ "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
|
||||
[ ] [ [ 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-basic-blocks
|
||||
[ ##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-basic-blocks
|
||||
[ [ ##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-basic-blocks
|
||||
[ [ ##load-immediate? ] count 2 assert= ]
|
||||
[ [ ##peek? ] count 1 assert= ]
|
||||
[ [ ##replace? ] count 1 assert= ]
|
||||
tri
|
||||
] unit-test
|
||||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs kernel namespaces math sequences fry deques grouping
|
||||
search-deques dlists sets make combinators compiler.cfg.copy-prop
|
||||
compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.registers
|
||||
compiler.cfg.rpo compiler.cfg.hats ;
|
||||
USING: accessors assocs kernel namespaces math sequences fry grouping
|
||||
sets make combinators compiler.cfg.copy-prop compiler.cfg.def-use
|
||||
compiler.cfg.instructions compiler.cfg.registers compiler.cfg.rpo
|
||||
compiler.cfg.hats ;
|
||||
IN: compiler.cfg.stack-analysis
|
||||
|
||||
! Convert stack operations to register operations
|
||||
|
|
@ -34,19 +34,34 @@ M: state clone
|
|||
: changed-loc ( loc -- )
|
||||
state get changed-locs>> conjoin ;
|
||||
|
||||
: changed-loc? ( loc -- ? )
|
||||
state get changed-locs>> key? ;
|
||||
|
||||
: record-replace ( src loc -- )
|
||||
dup changed-loc state get locs>vregs>> set-at ;
|
||||
|
||||
GENERIC: height-for ( loc -- n )
|
||||
|
||||
M: ds-loc height-for drop state get d-height>> ;
|
||||
M: rs-loc height-for drop state get r-height>> ;
|
||||
|
||||
: (translate-loc) ( loc -- n height ) [ n>> ] [ height-for ] bi ; inline
|
||||
|
||||
GENERIC: translate-loc ( loc -- loc' )
|
||||
|
||||
M: ds-loc translate-loc (translate-loc) - <ds-loc> ;
|
||||
M: rs-loc translate-loc (translate-loc) - <rs-loc> ;
|
||||
|
||||
GENERIC: untranslate-loc ( loc -- loc' )
|
||||
|
||||
M: ds-loc untranslate-loc (translate-loc) + <ds-loc> ;
|
||||
M: rs-loc untranslate-loc (translate-loc) + <rs-loc> ;
|
||||
|
||||
: redundant-replace? ( vreg loc -- ? )
|
||||
state get actual-locs>vregs>> at = ;
|
||||
dup untranslate-loc n>> 0 <
|
||||
[ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
|
||||
|
||||
: save-changed-locs ( state -- )
|
||||
[ changed-locs>> ] [ locs>vregs>> ] bi '[
|
||||
_ at swap 2dup redundant-replace?
|
||||
[ 2drop ] [ ##replace ] if
|
||||
[ 2drop ] [ untranslate-loc ##replace ] if
|
||||
] assoc-each ;
|
||||
|
||||
: clear-state ( state -- )
|
||||
|
|
@ -66,12 +81,6 @@ ERROR: poisoned-state state ;
|
|||
|
||||
: poison-state ( -- ) state get t >>poisoned? drop ;
|
||||
|
||||
GENERIC: translate-loc ( loc -- loc' )
|
||||
|
||||
M: ds-loc translate-loc n>> state get d-height>> + <ds-loc> ;
|
||||
|
||||
M: rs-loc translate-loc n>> state get r-height>> + <rs-loc> ;
|
||||
|
||||
! Abstract interpretation
|
||||
GENERIC: visit ( insn -- )
|
||||
|
||||
|
|
@ -162,12 +171,6 @@ M: ##alien-callback visit , ;
|
|||
|
||||
M: ##dispatch-label visit , ;
|
||||
|
||||
! Basic blocks we still need to look at
|
||||
SYMBOL: work-list
|
||||
|
||||
: add-to-work-list ( basic-block -- )
|
||||
work-list get push-front ;
|
||||
|
||||
! Maps basic-blocks to states
|
||||
SYMBOLS: state-in state-out ;
|
||||
|
||||
|
|
@ -222,8 +225,20 @@ SYMBOL: phi-nodes
|
|||
: merge-locs ( state predecessors states -- state )
|
||||
[ locs>vregs>> ] map (merge-locs) >>locs>vregs ;
|
||||
|
||||
: merge-loc' ( locs>vregs loc -- vreg )
|
||||
! Insert a ##phi in the current block where the input
|
||||
! is the vreg storing loc from each predecessor block
|
||||
'[ [ _ ] dip at ] map
|
||||
dup all-equal? [ first ] [ drop f ] if ;
|
||||
|
||||
: merge-actual-locs ( state predecessors states -- state )
|
||||
[ actual-locs>vregs>> ] map (merge-locs) >>actual-locs>vregs ;
|
||||
nip
|
||||
[ actual-locs>vregs>> ] map
|
||||
dup [ keys ] map concat prune
|
||||
[ [ nip ] [ merge-loc' ] 2bi ] with
|
||||
H{ } map>assoc
|
||||
[ nip ] assoc-filter
|
||||
>>actual-locs>vregs ;
|
||||
|
||||
: merge-changed-locs ( state predecessors states -- state )
|
||||
nip [ changed-locs>> ] map assoc-combine >>changed-locs ;
|
||||
|
|
@ -266,12 +281,8 @@ ERROR: cannot-merge-poisoned states ;
|
|||
: set-block-in-state ( state bb -- )
|
||||
[ clone ] dip state-in get set-at ;
|
||||
|
||||
: set-block-out-state ( state bb -- changed? )
|
||||
[ clone ] dip state-out get maybe-set-at ;
|
||||
|
||||
: finish-block ( bb state -- )
|
||||
[ drop ] [ swap set-block-out-state ] 2bi
|
||||
[ successors>> [ add-to-work-list ] each ] [ drop ] if ;
|
||||
: 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
|
||||
|
|
@ -281,21 +292,17 @@ ERROR: cannot-merge-poisoned states ;
|
|||
[ swap set-block-in-state ] [
|
||||
[
|
||||
[ instructions>> [ visit ] each ]
|
||||
[ state get finish-block ]
|
||||
[ [ state get ] dip set-block-out-state ]
|
||||
[ ]
|
||||
tri
|
||||
] with-state
|
||||
] 2bi
|
||||
] V{ } make >>instructions drop ;
|
||||
|
||||
: visit-blocks ( bb -- )
|
||||
reverse-post-order [ visit-block ] each ;
|
||||
|
||||
: optimize-stack ( cfg -- cfg )
|
||||
: optimize-stack ( rpo -- rpo )
|
||||
[
|
||||
H{ } clone copies set
|
||||
H{ } clone state-in set
|
||||
H{ } clone state-out set
|
||||
<hashed-dlist> work-list set
|
||||
dup entry>> visit-blocks
|
||||
dup [ visit-block ] each
|
||||
] with-scope ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue