140 lines
3.4 KiB
Factor
140 lines
3.4 KiB
Factor
! Copyright (C) 2009 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: namespaces kernel accessors sequences fry assocs
|
|
sets math combinators
|
|
compiler.cfg
|
|
compiler.cfg.rpo
|
|
compiler.cfg.def-use
|
|
compiler.cfg.liveness
|
|
compiler.cfg.registers
|
|
compiler.cfg.dominance
|
|
compiler.cfg.instructions
|
|
compiler.cfg.renaming
|
|
compiler.cfg.renaming.functor
|
|
compiler.cfg.ssa.construction.tdmsc ;
|
|
FROM: namespaces => set ;
|
|
IN: compiler.cfg.ssa.construction
|
|
|
|
! The phi placement algorithm is implemented in
|
|
! compiler.cfg.ssa.construction.tdmsc.
|
|
|
|
! The renaming algorithm is based on "Practical Improvements to
|
|
! the Construction and Destruction of Static Single Assignment Form",
|
|
! however we construct pruned SSA, not semi-pruned SSA.
|
|
|
|
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.49.9683
|
|
|
|
<PRIVATE
|
|
|
|
! Maps vregs to sets of basic blocks
|
|
SYMBOL: defs
|
|
|
|
! Set of vregs defined in more than one basic block
|
|
SYMBOL: defs-multi
|
|
|
|
: compute-insn-defs ( bb insn -- )
|
|
defs-vreg dup [
|
|
defs get [ conjoin-at ] [ drop ] [ at assoc-size 1 > ] 2tri
|
|
[ defs-multi get conjoin ] [ drop ] if
|
|
] [ 2drop ] if ;
|
|
|
|
: compute-defs ( cfg -- )
|
|
H{ } clone defs set
|
|
H{ } clone defs-multi set
|
|
[
|
|
dup instructions>> [
|
|
compute-insn-defs
|
|
] with each
|
|
] each-basic-block ;
|
|
|
|
! Maps basic blocks to sequences of vregs
|
|
SYMBOL: inserting-phi-nodes
|
|
|
|
: insert-phi-node-later ( vreg bb -- )
|
|
2dup live-in key? [
|
|
[ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep
|
|
inserting-phi-nodes get push-at
|
|
] [ 2drop ] if ;
|
|
|
|
: compute-phi-nodes-for ( vreg bbs -- )
|
|
keys merge-set [ insert-phi-node-later ] with each ;
|
|
|
|
: compute-phi-nodes ( -- )
|
|
H{ } clone inserting-phi-nodes set
|
|
defs-multi get defs get '[ _ at compute-phi-nodes-for ] assoc-each ;
|
|
|
|
: insert-phi-nodes-in ( phis bb -- )
|
|
[ append ] change-instructions drop ;
|
|
|
|
: insert-phi-nodes ( -- )
|
|
inserting-phi-nodes get [ swap insert-phi-nodes-in ] assoc-each ;
|
|
|
|
SYMBOLS: stacks pushed ;
|
|
|
|
: init-renaming ( -- )
|
|
H{ } clone stacks set ;
|
|
|
|
: gen-name ( vreg -- vreg' )
|
|
[ next-vreg dup ] dip
|
|
dup pushed get 2dup key?
|
|
[ 2drop stacks get at set-last ]
|
|
[ conjoin stacks get push-at ]
|
|
if ;
|
|
|
|
: top-name ( vreg -- vreg' )
|
|
stacks get at last ;
|
|
|
|
RENAMING: ssa-rename [ gen-name ] [ top-name ] [ ]
|
|
|
|
GENERIC: rename-insn ( insn -- )
|
|
|
|
M: insn rename-insn
|
|
[ ssa-rename-insn-uses ]
|
|
[ ssa-rename-insn-defs ]
|
|
bi ;
|
|
|
|
M: ##phi rename-insn
|
|
ssa-rename-insn-defs ;
|
|
|
|
: rename-insns ( bb -- )
|
|
instructions>> [ rename-insn ] each ;
|
|
|
|
: rename-successor-phi ( phi bb -- )
|
|
swap inputs>> [ top-name ] change-at ;
|
|
|
|
: rename-successor-phis ( succ bb -- )
|
|
[ inserting-phi-nodes get at ] dip
|
|
'[ _ rename-successor-phi ] each ;
|
|
|
|
: rename-successors-phis ( bb -- )
|
|
[ successors>> ] keep '[ _ rename-successor-phis ] each ;
|
|
|
|
: pop-stacks ( -- )
|
|
pushed get stacks get '[ drop _ at pop* ] assoc-each ;
|
|
|
|
: rename-in-block ( bb -- )
|
|
H{ } clone pushed set
|
|
[ rename-insns ]
|
|
[ rename-successors-phis ]
|
|
[
|
|
pushed get
|
|
[ dom-children [ rename-in-block ] each ] dip
|
|
pushed set
|
|
] tri
|
|
pop-stacks ;
|
|
|
|
: rename ( cfg -- )
|
|
init-renaming
|
|
entry>> rename-in-block ;
|
|
|
|
PRIVATE>
|
|
|
|
: construct-ssa ( cfg -- cfg' )
|
|
{
|
|
[ compute-live-sets ]
|
|
[ compute-merge-sets ]
|
|
[ compute-defs compute-phi-nodes insert-phi-nodes ]
|
|
[ rename ]
|
|
[ ]
|
|
} cleave ;
|