]> gitweb.factorcode.org Git - factor.git/blob - basis/compiler/cfg/builder/builder.factor
28682c91a81edd3059a2e2a42d6e1dbff22e9365
[factor.git] / basis / compiler / cfg / builder / builder.factor
1 ! Copyright (C) 2004, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators hashtables kernel
4 math fry namespaces make sequences words byte-arrays
5 layouts alien.c-types
6 stack-checker.inlining cpu.architecture
7 compiler.tree
8 compiler.tree.builder
9 compiler.tree.combinators
10 compiler.tree.propagation.info
11 compiler.cfg
12 compiler.cfg.hats
13 compiler.cfg.utilities
14 compiler.cfg.registers
15 compiler.cfg.intrinsics
16 compiler.cfg.comparisons
17 compiler.cfg.stack-frame
18 compiler.cfg.instructions
19 compiler.cfg.predecessors
20 compiler.cfg.builder.blocks
21 compiler.cfg.stacks
22 compiler.cfg.stacks.local ;
23 IN: compiler.cfg.builder
24
25 ! Convert tree SSA IR to CFG IR. The result is not in SSA form; this is
26 ! constructed later by calling compiler.cfg.ssa.construction:construct-ssa.
27
28 SYMBOL: procedures
29 SYMBOL: loops
30
31 : begin-cfg ( word label -- cfg )
32     initial-basic-block
33     H{ } clone loops set
34     [ basic-block get ] 2dip <cfg> dup cfg set ;
35
36 : begin-procedure ( word label -- )
37     begin-cfg procedures get push ;
38
39 : with-cfg-builder ( nodes word label quot -- )
40     '[
41         begin-stack-analysis
42         begin-procedure
43         @
44         end-stack-analysis
45     ] with-scope ; inline
46
47 : with-dummy-cfg-builder ( node quot -- )
48     [
49         [ V{ } clone procedures ] 2dip
50         '[ _ t t [ _ call( node -- ) ] with-cfg-builder ] with-variable
51     ] { } make drop ;
52
53 GENERIC: emit-node ( node -- )
54
55 : emit-nodes ( nodes -- )
56     [ basic-block get [ emit-node ] [ drop ] if ] each ;
57
58 : begin-word ( -- )
59     make-kill-block
60     ##safepoint,
61     ##prologue,
62     ##branch,
63     begin-basic-block ;
64
65 : (build-cfg) ( nodes word label -- )
66     [
67         begin-word
68         emit-nodes
69     ] with-cfg-builder ;
70
71 : build-cfg ( nodes word -- procedures )
72     V{ } clone [
73         procedures [
74             dup (build-cfg)
75         ] with-variable
76     ] keep ;
77
78 : emit-loop-call ( basic-block -- )
79     ##safepoint,
80     ##branch,
81     basic-block get successors>> push
82     end-basic-block ;
83
84 : emit-call ( word height -- )
85     over loops get key?
86     [ drop loops get at emit-loop-call ]
87     [
88         [
89             [ ##call, ] [ adjust-d ] bi*
90             make-kill-block
91         ] emit-trivial-block
92     ] if ;
93
94 ! #recursive
95 : recursive-height ( #recursive -- n )
96     [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
97
98 : emit-recursive ( #recursive -- )
99     [ [ label>> id>> ] [ recursive-height ] bi emit-call ]
100     [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
101
102 : remember-loop ( label -- )
103     basic-block get swap loops get set-at ;
104
105 : emit-loop ( node -- )
106     ##branch,
107     begin-basic-block
108     [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ;
109
110 M: #recursive emit-node
111     dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
112
113 ! #if
114 : emit-branch ( obj -- final-bb )
115     [ emit-nodes ] with-branch ;
116
117 : emit-if ( node -- )
118     children>> [ emit-branch ] map emit-conditional ;
119
120 : trivial-branch? ( nodes -- value ? )
121     dup length 1 = [
122         first dup #push? [ literal>> t ] [ drop f f ] if
123     ] [ drop f f ] if ;
124
125 : trivial-if? ( #if -- ? )
126     children>> first2
127     [ trivial-branch? [ t eq? ] when ]
128     [ trivial-branch? [ f eq? ] when ] bi*
129     and ;
130
131 : emit-trivial-if ( -- )
132     [ f cc/= ^^compare-imm ] unary-op ;
133
134 : trivial-not-if? ( #if -- ? )
135     children>> first2
136     [ trivial-branch? [ f eq? ] when ]
137     [ trivial-branch? [ t eq? ] when ] bi*
138     and ;
139
140 : emit-trivial-not-if ( -- )
141     [ f cc= ^^compare-imm ] unary-op ;
142
143 : emit-actual-if ( #if -- )
144     ! Inputs to the final instruction need to be copied because of
145     ! loc>vreg sync
146     ds-pop any-rep ^^copy f cc/= ##compare-imm-branch, emit-if ;
147
148 M: #if emit-node
149     {
150         { [ dup trivial-if? ] [ drop emit-trivial-if ] }
151         { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
152         [ emit-actual-if ]
153     } cond ;
154
155 ! #dispatch
156 M: #dispatch emit-node
157     ! Inputs to the final instruction need to be copied because of
158     ! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
159     ! though.
160     ds-pop ^^offset>slot next-vreg ##dispatch, emit-if ;
161
162 ! #call
163 M: #call emit-node
164     dup word>> dup "intrinsic" word-prop
165     [ emit-intrinsic ] [ swap call-height emit-call ] if ;
166
167 ! #call-recursive
168 M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
169
170 ! #push
171 M: #push emit-node
172     literal>> ^^load-literal ds-push ;
173
174 ! #shuffle
175
176 ! Even though low level IR has its own dead code elimination pass,
177 ! we try not to introduce useless ##peeks here, since this reduces
178 ! the accuracy of global stack analysis.
179
180 : make-input-map ( #shuffle -- assoc )
181     ! Assoc maps high-level IR values to stack locations.
182     [
183         [ in-d>> <reversed> [ <ds-loc> swap set ] each-index ]
184         [ in-r>> <reversed> [ <rs-loc> swap set ] each-index ] bi
185     ] H{ } make-assoc ;
186
187 : make-output-seq ( values mapping input-map -- vregs )
188     '[ _ at _ at peek-loc ] map ;
189
190 : load-shuffle ( #shuffle mapping input-map -- ds-vregs rs-vregs )
191     [ [ out-d>> ] 2dip make-output-seq ]
192     [ [ out-r>> ] 2dip make-output-seq ] 3bi ;
193
194 : store-shuffle ( #shuffle ds-vregs rs-vregs -- )
195     [ [ in-d>> length neg inc-d ] dip ds-store ]
196     [ [ in-r>> length neg inc-r ] dip rs-store ]
197     bi-curry* bi ;
198
199 M: #shuffle emit-node
200     dup dup [ mapping>> ] [ make-input-map ] bi load-shuffle store-shuffle ;
201
202 ! #return
203 : end-word ( -- )
204     ##branch,
205     begin-basic-block
206     make-kill-block
207     ##safepoint,
208     ##epilogue,
209     ##return, ;
210
211 M: #return emit-node drop end-word ;
212
213 M: #return-recursive emit-node
214     label>> id>> loops get key? [ end-word ] unless ;
215
216 ! #terminate
217 M: #terminate emit-node drop ##no-tco, end-basic-block ;
218
219 ! No-op nodes
220 M: #introduce emit-node drop ;
221
222 M: #copy emit-node drop ;
223
224 M: #enter-recursive emit-node drop ;
225
226 M: #phi emit-node drop ;
227
228 M: #declare emit-node drop ;