1 ! Copyright (C) 2008, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel math accessors sequences namespaces make
4 combinators assocs arrays locals cpu.architecture
7 compiler.cfg.comparisons
8 compiler.cfg.stack-frame
9 compiler.cfg.instructions ;
10 IN: compiler.cfg.linearization
12 ! Convert CFG IR to machine IR.
13 GENERIC: linearize-insn ( basic-block insn -- )
15 : linearize-basic-block ( bb -- )
17 [ dup instructions>> [ linearize-insn ] with each ]
20 M: insn linearize-insn , drop ;
22 : useless-branch? ( basic-block successor -- ? )
23 #! If our successor immediately follows us in RPO, then we
24 #! don't need to branch.
25 [ number>> ] bi@ 1 - = ; inline
27 : emit-branch ( basic-block successor -- )
28 2dup useless-branch? [ 2drop ] [ nip number>> _branch ] if ;
30 M: ##branch linearize-insn
31 drop dup successors>> first emit-branch ;
33 : successors ( bb -- first second ) successors>> first2 ; inline
35 : (binary-conditional) ( basic-block insn -- basic-block successor1 successor2 src1 src2 cc )
37 [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
39 : binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
40 [ (binary-conditional) ]
41 [ drop dup successors>> second useless-branch? ] 2bi
42 [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
44 : with-regs ( insn quot -- )
45 over regs>> [ call ] dip building get last (>>regs) ; inline
47 M: ##compare-branch linearize-insn
48 [ binary-conditional _compare-branch ] with-regs emit-branch ;
50 M: ##compare-imm-branch linearize-insn
51 [ binary-conditional _compare-imm-branch ] with-regs emit-branch ;
53 M: ##compare-float-branch linearize-insn
54 [ binary-conditional _compare-float-branch ] with-regs emit-branch ;
56 : overflow-conditional ( basic-block insn -- basic-block successor label2 dst src1 src2 )
57 [ dup successors number>> ]
58 [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
60 M: ##fixnum-add linearize-insn
61 [ overflow-conditional _fixnum-add ] with-regs emit-branch ;
63 M: ##fixnum-sub linearize-insn
64 [ overflow-conditional _fixnum-sub ] with-regs emit-branch ;
66 M: ##fixnum-mul linearize-insn
67 [ overflow-conditional _fixnum-mul ] with-regs emit-branch ;
69 M: ##dispatch linearize-insn
71 [ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]
72 [ successors>> [ number>> _dispatch-label ] each ]
75 : (compute-gc-roots) ( n live-values -- n )
78 [ drop reg-class>> reg-size + ]
82 : oop-values ( regs -- regs' )
83 [ drop reg-class>> int-regs eq? ] assoc-filter ;
85 : data-values ( regs -- regs' )
86 [ drop reg-class>> double-float-regs eq? ] assoc-filter ;
88 : compute-gc-roots ( live-values -- alist )
91 ! we put float registers last; the GC doesn't actually scan them
92 [ oop-values (compute-gc-roots) ]
93 [ data-values (compute-gc-roots) ] bi
97 : count-gc-roots ( live-values -- n )
98 ! Size of GC root area, minus the float registers
99 oop-values assoc-size ;
101 M: ##gc linearize-insn
116 : linearize-basic-blocks ( cfg -- insns )
118 [ [ linearize-basic-block ] each-basic-block ]
119 [ spill-counts>> _spill-counts ]
123 : flatten-cfg ( cfg -- mr )
124 [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri