80 lines
2.3 KiB
Factor
80 lines
2.3 KiB
Factor
! Copyright (C) 2009 Doug Coleman, Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors combinators.short-circuit kernel math math.order
|
|
sequences assocs namespaces vectors fry arrays splitting
|
|
compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
|
|
compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ;
|
|
IN: compiler.cfg.branch-splitting
|
|
|
|
: clone-renamings ( insns -- assoc )
|
|
[ defs-vregs ] map concat [ dup fresh-vreg ] H{ } map>assoc ;
|
|
|
|
: clone-instructions ( insns -- insns' )
|
|
dup clone-renamings renamings [
|
|
[
|
|
clone
|
|
dup rename-insn-defs
|
|
dup rename-insn-uses
|
|
dup fresh-insn-temps
|
|
] map
|
|
] with-variable ;
|
|
|
|
: clone-basic-block ( bb -- bb' )
|
|
! The new block gets the same RPO number as the old one.
|
|
! This is just to make 'back-edge?' work.
|
|
<basic-block>
|
|
swap
|
|
[ instructions>> clone-instructions >>instructions ]
|
|
[ successors>> clone >>successors ]
|
|
[ number>> >>number ]
|
|
tri ;
|
|
|
|
: new-blocks ( bb -- copies )
|
|
dup predecessors>> [
|
|
[ clone-basic-block ] dip
|
|
1vector >>predecessors
|
|
] with map ;
|
|
|
|
: update-predecessor-successor ( pred copy old-bb -- )
|
|
'[
|
|
[ _ _ 3dup nip eq? [ drop nip ] [ 2drop ] if ] map
|
|
] change-successors drop ;
|
|
|
|
: update-predecessor-successors ( copies old-bb -- )
|
|
[ predecessors>> swap ] keep
|
|
'[ _ update-predecessor-successor ] 2each ;
|
|
|
|
: update-successor-predecessor ( copies old-bb succ -- )
|
|
[
|
|
swap 1array split swap join V{ } like
|
|
] change-predecessors drop ;
|
|
|
|
: update-successor-predecessors ( copies old-bb -- )
|
|
dup successors>> [
|
|
update-successor-predecessor
|
|
] with with each ;
|
|
|
|
: split-branch ( bb -- )
|
|
[ new-blocks ] keep
|
|
[ update-predecessor-successors ]
|
|
[ update-successor-predecessors ]
|
|
2bi ;
|
|
|
|
UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ;
|
|
|
|
: split-instructions? ( insns -- ? )
|
|
[ irrelevant? not ] count 5 <= ;
|
|
|
|
: split-branch? ( bb -- ? )
|
|
{
|
|
[ dup successors>> [ back-edge? ] with any? not ]
|
|
[ predecessors>> length 2 4 between? ]
|
|
[ instructions>> split-instructions? ]
|
|
} 1&& ;
|
|
|
|
: split-branches ( cfg -- cfg' )
|
|
dup [
|
|
dup split-branch? [ split-branch ] [ drop ] if
|
|
] each-basic-block
|
|
cfg-changed ;
|