132 lines
3.8 KiB
Factor
Executable File
132 lines
3.8 KiB
Factor
Executable File
! Copyright (C) 2008, 2009 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: kernel math accessors sequences namespaces make
|
|
combinators assocs arrays locals cpu.architecture
|
|
compiler.cfg
|
|
compiler.cfg.rpo
|
|
compiler.cfg.liveness
|
|
compiler.cfg.stack-frame
|
|
compiler.cfg.instructions ;
|
|
IN: compiler.cfg.linearization
|
|
|
|
! Convert CFG IR to machine IR.
|
|
GENERIC: linearize-insn ( basic-block insn -- )
|
|
|
|
: linearize-basic-block ( bb -- )
|
|
[ number>> _label ]
|
|
[ dup instructions>> [ linearize-insn ] with each ]
|
|
bi ;
|
|
|
|
M: insn linearize-insn , drop ;
|
|
|
|
: useless-branch? ( basic-block successor -- ? )
|
|
#! If our successor immediately follows us in RPO, then we
|
|
#! don't need to branch.
|
|
[ number>> ] bi@ 1 - = ; inline
|
|
|
|
: branch-to-branch? ( successor -- ? )
|
|
#! A branch to a block containing just a jump return is cloned.
|
|
instructions>> dup length 2 = [
|
|
[ first ##epilogue? ]
|
|
[ second [ ##return? ] [ ##jump? ] bi or ] bi and
|
|
] [ drop f ] if ;
|
|
|
|
: emit-branch ( basic-block successor -- )
|
|
{
|
|
{ [ 2dup useless-branch? ] [ 2drop ] }
|
|
{ [ dup branch-to-branch? ] [ nip linearize-basic-block ] }
|
|
[ nip number>> _branch ]
|
|
} cond ;
|
|
|
|
M: ##branch linearize-insn
|
|
drop dup successors>> first emit-branch ;
|
|
|
|
: (binary-conditional) ( basic-block insn -- basic-block successor1 successor2 src1 src2 cc )
|
|
[ dup successors>> first2 ]
|
|
[ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
|
|
|
|
: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
|
|
[ (binary-conditional) ]
|
|
[ drop dup successors>> second useless-branch? ] 2bi
|
|
[ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
|
|
|
|
: with-regs ( insn quot -- )
|
|
over regs>> [ call ] dip building get last (>>regs) ; inline
|
|
|
|
M: ##compare-branch linearize-insn
|
|
[ binary-conditional _compare-branch ] with-regs emit-branch ;
|
|
|
|
M: ##compare-imm-branch linearize-insn
|
|
[ binary-conditional _compare-imm-branch ] with-regs emit-branch ;
|
|
|
|
M: ##compare-float-branch linearize-insn
|
|
[ binary-conditional _compare-float-branch ] with-regs emit-branch ;
|
|
|
|
M: ##dispatch linearize-insn
|
|
swap
|
|
[ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]
|
|
[ successors>> [ number>> _dispatch-label ] each ]
|
|
bi* ;
|
|
|
|
: gc-root-registers ( n live-registers -- n )
|
|
[
|
|
[ second 2array , ]
|
|
[ first reg-class>> reg-size + ]
|
|
2bi
|
|
] each ;
|
|
|
|
: gc-root-spill-slots ( n live-spill-slots -- n )
|
|
[
|
|
dup first reg-class>> int-regs eq? [
|
|
[ second <spill-slot> 2array , ]
|
|
[ first reg-class>> reg-size + ]
|
|
2bi
|
|
] [ drop ] if
|
|
] each ;
|
|
|
|
: oop-registers ( regs -- regs' )
|
|
[ first reg-class>> int-regs eq? ] filter ;
|
|
|
|
: data-registers ( regs -- regs' )
|
|
[ first reg-class>> double-float-regs eq? ] filter ;
|
|
|
|
:: compute-gc-roots ( live-registers live-spill-slots -- alist )
|
|
[
|
|
0
|
|
! we put float registers last; the GC doesn't actually scan them
|
|
live-registers oop-registers gc-root-registers
|
|
live-spill-slots gc-root-spill-slots
|
|
live-registers data-registers gc-root-registers
|
|
drop
|
|
] { } make ;
|
|
|
|
: count-gc-roots ( live-registers live-spill-slots -- n )
|
|
! Size of GC root area, minus the float registers
|
|
[ oop-registers length ] bi@ + ;
|
|
|
|
M: ##gc linearize-insn
|
|
nip
|
|
[
|
|
[ temp1>> ]
|
|
[ temp2>> ]
|
|
[
|
|
[ live-registers>> ] [ live-spill-slots>> ] bi
|
|
[ compute-gc-roots ]
|
|
[ count-gc-roots ]
|
|
[ gc-roots-size ]
|
|
2tri
|
|
] tri
|
|
_gc
|
|
] with-regs ;
|
|
|
|
: linearize-basic-blocks ( cfg -- insns )
|
|
[
|
|
[ [ linearize-basic-block ] each-basic-block ]
|
|
[ spill-counts>> _spill-counts ]
|
|
bi
|
|
] { } make ;
|
|
|
|
: flatten-cfg ( cfg -- mr )
|
|
[ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
|
|
<mr> ;
|