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
6 compiler.cfg.comparisons
7 compiler.cfg.stack-frame
8 compiler.cfg.instructions
10 compiler.cfg.linearization.order ;
11 IN: compiler.cfg.linearization
13 ! Convert CFG IR to machine IR.
14 GENERIC: linearize-insn ( basic-block insn -- )
16 : linearize-basic-block ( bb -- )
17 [ block-number _label ]
18 [ dup instructions>> [ linearize-insn ] with each ]
21 M: insn linearize-insn , drop ;
23 : useless-branch? ( basic-block successor -- ? )
24 ! If our successor immediately follows us in linearization
25 ! order then we don't need to branch.
26 [ block-number ] bi@ 1 - = ; inline
28 : emit-branch ( bb successor -- )
29 2dup useless-branch? [ 2drop ] [ nip block-number _branch ] if ;
31 M: ##branch linearize-insn
32 drop dup successors>> first emit-branch ;
34 : successors ( bb -- first second ) successors>> first2 ; inline
36 : (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc )
38 [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
40 : binary-conditional ( bb insn -- bb successor label2 src1 src2 cc )
41 [ (binary-conditional) ]
42 [ drop dup successors>> second useless-branch? ] 2bi
43 [ [ swap block-number ] 3dip ] [ [ block-number ] 3dip negate-cc ] if ;
45 M: ##compare-branch linearize-insn
46 binary-conditional _compare-branch emit-branch ;
48 M: ##compare-imm-branch linearize-insn
49 binary-conditional _compare-imm-branch emit-branch ;
51 M: ##compare-float-branch linearize-insn
52 binary-conditional _compare-float-branch emit-branch ;
54 : overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
55 [ dup successors block-number ]
56 [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
58 M: ##fixnum-add linearize-insn
59 overflow-conditional _fixnum-add emit-branch ;
61 M: ##fixnum-sub linearize-insn
62 overflow-conditional _fixnum-sub emit-branch ;
64 M: ##fixnum-mul linearize-insn
65 overflow-conditional _fixnum-mul emit-branch ;
67 M: ##dispatch linearize-insn
69 [ [ src>> ] [ temp>> ] bi _dispatch ]
70 [ successors>> [ block-number _dispatch-label ] each ]
73 : (compute-gc-roots) ( n live-values -- n )
76 [ drop reg-class>> reg-size + ]
80 : oop-values ( regs -- regs' )
81 [ drop reg-class>> int-regs eq? ] assoc-filter ;
83 : data-values ( regs -- regs' )
84 [ drop reg-class>> double-float-regs eq? ] assoc-filter ;
86 : compute-gc-roots ( live-values -- alist )
89 ! we put float registers last; the GC doesn't actually scan them
90 [ oop-values (compute-gc-roots) ]
91 [ data-values (compute-gc-roots) ] bi
95 : count-gc-roots ( live-values -- n )
96 ! Size of GC root area, minus the float registers
97 oop-values assoc-size ;
99 M: ##gc linearize-insn
112 : linearize-basic-blocks ( cfg -- insns )
114 [ linearization-order [ linearize-basic-block ] each ]
115 [ spill-counts>> _spill-counts ]
119 : flatten-cfg ( cfg -- mr )
120 [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri