1 ! Copyright (C) 2004, 2009 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
6 stack-checker.inlining cpu.architecture
9 compiler.tree.combinators
10 compiler.tree.propagation.info
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
22 compiler.cfg.stacks.local
24 IN: compiler.cfg.builder
26 ! Convert tree SSA IR to CFG IR. The result is not in SSA form; this is
27 ! constructed later by calling compiler.cfg.ssa.construction:construct-ssa.
32 : begin-cfg ( word label -- cfg )
35 [ basic-block get ] 2dip <cfg> dup cfg set ;
37 : begin-procedure ( word label -- )
38 begin-cfg procedures get push ;
40 : with-cfg-builder ( nodes word label quot -- )
48 GENERIC: emit-node ( node -- )
50 : emit-nodes ( nodes -- )
51 [ basic-block get [ emit-node ] [ drop ] if ] each ;
58 : (build-cfg) ( nodes word label -- )
64 : build-cfg ( nodes word -- procedures )
71 : emit-loop-call ( basic-block -- )
73 basic-block get successors>> push
76 : emit-call ( word height -- )
78 [ drop loops get at emit-loop-call ]
79 [ [ [ ##call ] [ adjust-d ] bi* ] emit-trivial-block ]
83 : recursive-height ( #recursive -- n )
84 [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
86 : emit-recursive ( #recursive -- )
87 [ [ label>> id>> ] [ recursive-height ] bi emit-call ]
88 [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
90 : remember-loop ( label -- )
91 basic-block get swap loops get set-at ;
93 : emit-loop ( node -- )
96 [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ;
98 M: #recursive emit-node
99 dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
102 : emit-branch ( obj -- final-bb )
103 [ emit-nodes ] with-branch ;
105 : emit-if ( node -- )
106 children>> [ emit-branch ] map emit-conditional ;
108 : trivial-branch? ( nodes -- value ? )
110 first dup #push? [ literal>> t ] [ drop f f ] if
113 : trivial-if? ( #if -- ? )
115 [ trivial-branch? [ t eq? ] when ]
116 [ trivial-branch? [ f eq? ] when ] bi*
119 : emit-trivial-if ( -- )
120 ds-pop \ f type-number cc/= ^^compare-imm ds-push ;
122 : trivial-not-if? ( #if -- ? )
124 [ trivial-branch? [ f eq? ] when ]
125 [ trivial-branch? [ t eq? ] when ] bi*
128 : emit-trivial-not-if ( -- )
129 ds-pop \ f type-number cc= ^^compare-imm ds-push ;
131 : emit-actual-if ( #if -- )
132 ! Inputs to the final instruction need to be copied because of
134 ds-pop any-rep ^^copy \ f type-number cc/= ##compare-imm-branch emit-if ;
138 { [ dup trivial-if? ] [ drop emit-trivial-if ] }
139 { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
144 M: #dispatch emit-node
145 ! Inputs to the final instruction need to be copied because of
146 ! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
148 ds-pop ^^offset>slot next-vreg ##dispatch emit-if ;
152 dup word>> dup "intrinsic" word-prop
153 [ emit-intrinsic ] [ swap call-height emit-call ] if ;
156 M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
160 literal>> ^^load-literal ds-push ;
164 ! Even though low level IR has its own dead code elimination pass,
165 ! we try not to introduce useless ##peeks here, since this reduces
166 ! the accuracy of global stack analysis.
168 : make-input-map ( #shuffle -- assoc )
169 ! Assoc maps high-level IR values to stack locations.
171 [ in-d>> <reversed> [ <ds-loc> swap set ] each-index ]
172 [ in-r>> <reversed> [ <rs-loc> swap set ] each-index ] bi
175 : make-output-seq ( values mapping input-map -- vregs )
176 '[ _ at _ at peek-loc ] map ;
178 : load-shuffle ( #shuffle mapping input-map -- ds-vregs rs-vregs )
179 [ [ out-d>> ] 2dip make-output-seq ]
180 [ [ out-r>> ] 2dip make-output-seq ] 3bi ;
182 : store-shuffle ( #shuffle ds-vregs rs-vregs -- )
183 [ [ in-d>> length neg inc-d ] dip ds-store ]
184 [ [ in-r>> length neg inc-r ] dip rs-store ]
187 M: #shuffle emit-node
188 dup dup [ mapping>> ] [ make-input-map ] bi load-shuffle store-shuffle ;
192 ##branch begin-basic-block ##epilogue ##return ;
194 M: #return emit-node drop emit-return ;
196 M: #return-recursive emit-node
197 label>> id>> loops get key? [ emit-return ] unless ;
200 M: #terminate emit-node drop ##no-tco end-basic-block ;
203 : return-size ( ctype -- n )
204 #! Amount of space we reserve for a return value.
206 { [ dup c-struct? not ] [ drop 0 ] }
207 { [ dup large-struct? not ] [ drop 2 cells ] }
211 : <alien-stack-frame> ( params -- stack-frame )
214 [ return>> return-size >>return ]
215 [ alien-parameters parameter-offsets drop >>params ] bi
218 : alien-node-height ( params -- )
219 [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
221 : emit-alien-node ( node quot -- )
223 [ params>> dup dup <alien-stack-frame> ] dip call
225 ] emit-trivial-block ; inline
227 M: #alien-invoke emit-node
228 [ ##alien-invoke ] emit-alien-node ;
230 M: #alien-indirect emit-node
231 [ ##alien-indirect ] emit-alien-node ;
233 M: #alien-callback emit-node
234 dup params>> xt>> dup
237 dup [ ##alien-callback ] emit-alien-node
239 params>> ##callback-return
243 M: #introduce emit-node drop ;
245 M: #copy emit-node drop ;
247 M: #enter-recursive emit-node drop ;
249 M: #phi emit-node drop ;
251 M: #declare emit-node drop ;