compiler.cfg.stack-analysis: split up into three vocabs
Slava Pestov
parent
f3cf8fad2b
commit
22fa524db1
basis/compiler/cfg/stack-analysis
|
|
@ -0,0 +1,85 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel assocs sequences accessors fry combinators grouping
|
||||
sets compiler.cfg compiler.cfg.hats
|
||||
compiler.cfg.stack-analysis.state ;
|
||||
IN: compiler.cfg.stack-analysis.merge
|
||||
|
||||
: initial-state ( bb states -- state ) 2drop <state> ;
|
||||
|
||||
: single-predecessor ( bb states -- state ) nip first clone ;
|
||||
|
||||
ERROR: must-equal-failed seq ;
|
||||
|
||||
: must-equal ( seq -- elt )
|
||||
dup all-equal? [ first ] [ must-equal-failed ] if ;
|
||||
|
||||
: merge-heights ( state predecessors states -- state )
|
||||
nip
|
||||
[ [ ds-height>> ] map must-equal >>ds-height ]
|
||||
[ [ rs-height>> ] map must-equal >>rs-height ] bi ;
|
||||
|
||||
: insert-peek ( predecessor loc -- vreg )
|
||||
! XXX critical edges
|
||||
'[ _ ^^peek ] add-instructions ;
|
||||
|
||||
: merge-loc ( predecessors 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 ] keep
|
||||
'[ [ ] [ _ insert-peek ] ?if ] 2map
|
||||
dup all-equal? [ first ] [ ^^phi ] if ;
|
||||
|
||||
: (merge-locs) ( predecessors assocs -- assoc )
|
||||
dup [ keys ] map concat prune
|
||||
[ [ 2nip ] [ merge-loc ] 3bi ] with with
|
||||
H{ } map>assoc ;
|
||||
|
||||
: merge-locs ( state predecessors states -- state )
|
||||
[ locs>vregs>> ] map (merge-locs) >>locs>vregs ;
|
||||
|
||||
: merge-actual-loc ( locs>vregs loc -- vreg )
|
||||
'[ [ _ ] dip at ] map
|
||||
dup all-equal? [ first ] [ drop f ] if ;
|
||||
|
||||
: merge-actual-locs ( state predecessors states -- state )
|
||||
nip
|
||||
[ actual-locs>vregs>> ] map
|
||||
dup [ keys ] map concat prune
|
||||
[ [ nip ] [ merge-actual-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 ;
|
||||
|
||||
ERROR: cannot-merge-poisoned states ;
|
||||
|
||||
: multiple-predecessors ( bb states -- state )
|
||||
dup [ not ] any? [
|
||||
[ <state> ] 2dip
|
||||
sift merge-heights
|
||||
] [
|
||||
dup [ poisoned?>> ] any? [
|
||||
cannot-merge-poisoned
|
||||
] [
|
||||
[ state new ] 2dip
|
||||
[ predecessors>> ] dip
|
||||
{
|
||||
[ merge-locs ]
|
||||
[ merge-actual-locs ]
|
||||
[ merge-heights ]
|
||||
[ merge-changed-locs ]
|
||||
} 2cleave
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: merge-states ( bb states -- state )
|
||||
! If any states are poisoned, save all registers
|
||||
! to the stack in each branch
|
||||
dup length {
|
||||
{ 0 [ initial-state ] }
|
||||
{ 1 [ single-predecessor ] }
|
||||
[ drop multiple-predecessors ]
|
||||
} case ;
|
||||
|
|
@ -1,42 +1,19 @@
|
|||
! 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 compiler.cfg.copy-prop compiler.cfg.def-use
|
||||
compiler.cfg.instructions compiler.cfg.registers compiler.cfg.rpo
|
||||
compiler.cfg.hats compiler.cfg ;
|
||||
sets make combinators
|
||||
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 ;
|
||||
IN: compiler.cfg.stack-analysis
|
||||
|
||||
! Convert stack operations to register operations
|
||||
|
||||
! If 'poisoned' is set, disregard height information. This is set if we don't have
|
||||
! height change information for an instruction.
|
||||
TUPLE: state locs>vregs actual-locs>vregs changed-locs ds-height rs-height 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 ;
|
||||
|
||||
GENERIC: height-for ( loc -- n )
|
||||
|
||||
M: ds-loc height-for drop state get ds-height>> ;
|
||||
|
|
@ -64,12 +41,6 @@ M: rs-loc untranslate-loc (translate-loc) + <rs-loc> ;
|
|||
[ 2drop ] [ untranslate-loc ##replace ] if
|
||||
] assoc-each ;
|
||||
|
||||
: clear-state ( state -- )
|
||||
[ locs>vregs>> clear-assoc ]
|
||||
[ actual-locs>vregs>> clear-assoc ]
|
||||
[ changed-locs>> clear-assoc ]
|
||||
tri ;
|
||||
|
||||
ERROR: poisoned-state state ;
|
||||
|
||||
: sync-state ( -- )
|
||||
|
|
@ -84,6 +55,14 @@ ERROR: poisoned-state state ;
|
|||
! Abstract interpretation
|
||||
GENERIC: visit ( insn -- )
|
||||
|
||||
: adjust-ds ( n -- ) state get [ + ] change-ds-height drop ;
|
||||
|
||||
M: ##inc-d visit [ , ] [ n>> adjust-ds ] bi ;
|
||||
|
||||
: adjust-rs ( n -- ) state get [ + ] change-rs-height drop ;
|
||||
|
||||
M: ##inc-r visit [ , ] [ n>> adjust-rs ] bi ;
|
||||
|
||||
! Instructions which don't have any effect on the stack
|
||||
UNION: neutral-insn
|
||||
##flushable
|
||||
|
|
@ -113,14 +92,6 @@ t local-only? set-global
|
|||
M: sync-if-back-edge visit
|
||||
sync-state? [ sync-state ] when , ;
|
||||
|
||||
: adjust-d ( n -- ) state get [ + ] change-ds-height drop ;
|
||||
|
||||
M: ##inc-d visit [ , ] [ n>> adjust-d ] bi ;
|
||||
|
||||
: adjust-r ( n -- ) state get [ + ] change-rs-height drop ;
|
||||
|
||||
M: ##inc-r visit [ , ] [ n>> adjust-r ] bi ;
|
||||
|
||||
: eliminate-peek ( dst src -- )
|
||||
! the requested stack location is already in 'src'
|
||||
[ ##copy ] [ swap copies get set-at ] 2bi ;
|
||||
|
|
@ -138,7 +109,7 @@ M: ##copy visit
|
|||
[ call-next-method ] [ record-copy ] bi ;
|
||||
|
||||
M: ##call visit
|
||||
[ call-next-method ] [ height>> adjust-d ] bi ;
|
||||
[ call-next-method ] [ height>> adjust-ds ] bi ;
|
||||
|
||||
! Instructions that poison the stack state
|
||||
UNION: poison-insn
|
||||
|
|
@ -167,7 +138,7 @@ UNION: kill-vreg-insn
|
|||
M: kill-vreg-insn visit sync-state , ;
|
||||
|
||||
: visit-alien-node ( node -- )
|
||||
params>> [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
|
||||
params>> [ out-d>> length ] [ in-d>> length ] bi - adjust-ds ;
|
||||
|
||||
M: ##alien-invoke visit
|
||||
[ call-next-method ] [ visit-alien-node ] bi ;
|
||||
|
|
@ -180,87 +151,6 @@ M: ##alien-callback visit , ;
|
|||
! Maps basic-blocks to states
|
||||
SYMBOLS: state-in state-out ;
|
||||
|
||||
: initial-state ( bb states -- state ) 2drop <state> ;
|
||||
|
||||
: single-predecessor ( bb states -- state ) nip first clone ;
|
||||
|
||||
ERROR: must-equal-failed seq ;
|
||||
|
||||
: must-equal ( seq -- elt )
|
||||
dup all-equal? [ first ] [ must-equal-failed ] if ;
|
||||
|
||||
: merge-heights ( state predecessors states -- state )
|
||||
nip
|
||||
[ [ ds-height>> ] map must-equal >>ds-height ]
|
||||
[ [ rs-height>> ] map must-equal >>rs-height ] bi ;
|
||||
|
||||
: insert-peek ( predecessor loc -- vreg )
|
||||
! XXX critical edges
|
||||
'[ _ ^^peek ] add-instructions ;
|
||||
|
||||
: merge-loc ( predecessors 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 ] keep
|
||||
'[ [ ] [ _ insert-peek ] ?if ] 2map
|
||||
dup all-equal? [ first ] [ ^^phi ] if ;
|
||||
|
||||
: (merge-locs) ( predecessors assocs -- assoc )
|
||||
dup [ keys ] map concat prune
|
||||
[ [ 2nip ] [ merge-loc ] 3bi ] with with
|
||||
H{ } map>assoc ;
|
||||
|
||||
: 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 )
|
||||
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 ;
|
||||
|
||||
ERROR: cannot-merge-poisoned states ;
|
||||
|
||||
: multiple-predecessors ( bb states -- state )
|
||||
dup [ not ] any? [
|
||||
[ <state> ] 2dip
|
||||
sift merge-heights
|
||||
] [
|
||||
dup [ poisoned?>> ] any? [
|
||||
cannot-merge-poisoned
|
||||
] [
|
||||
[ state new ] 2dip
|
||||
[ predecessors>> ] dip
|
||||
{
|
||||
[ merge-locs ]
|
||||
[ merge-actual-locs ]
|
||||
[ merge-heights ]
|
||||
[ merge-changed-locs ]
|
||||
} 2cleave
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: merge-states ( bb states -- state )
|
||||
! If any states are poisoned, save all registers
|
||||
! to the stack in each branch
|
||||
dup length {
|
||||
{ 0 [ initial-state ] }
|
||||
{ 1 [ single-predecessor ] }
|
||||
[ drop multiple-predecessors ]
|
||||
} case ;
|
||||
|
||||
: block-in-state ( bb -- states )
|
||||
dup predecessors>> state-out get '[ _ at ] map merge-states ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,43 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors namespaces assocs sets math ;
|
||||
IN: compiler.cfg.stack-analysis.state
|
||||
|
||||
TUPLE: state
|
||||
locs>vregs actual-locs>vregs changed-locs
|
||||
ds-height rs-height 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 -- )
|
||||
[ locs>vregs>> clear-assoc ]
|
||||
[ actual-locs>vregs>> clear-assoc ]
|
||||
[ changed-locs>> clear-assoc ]
|
||||
tri ;
|
||||
|
||||
: adjust-ds ( n -- ) state get [ + ] change-ds-height drop ;
|
||||
|
||||
: adjust-rs ( n -- ) state get [ + ] change-rs-height drop ;
|
||||
Loading…
Reference in New Issue