1 ! Copyright (C) 2004, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators compiler.cfg
4 compiler.cfg.builder.blocks compiler.cfg.comparisons compiler.cfg.hats
5 compiler.cfg.instructions compiler.cfg.intrinsics compiler.cfg.registers
6 compiler.cfg.stacks compiler.cfg.stacks.local compiler.tree
7 compiler.cfg.utilities cpu.architecture fry kernel locals make math
8 namespaces sequences words ;
9 IN: compiler.cfg.builder
14 : begin-cfg ( word label -- cfg )
16 <basic-block> dup set-basic-block <cfg> dup cfg set ;
18 : with-cfg-builder ( nodes word label quot: ( ..a block -- ..b ) -- )
22 [ procedures get push ]
24 [ end-stack-analysis ] tri
27 : with-dummy-cfg-builder ( node quot -- )
29 [ V{ } clone procedures ] 2dip
30 '[ _ t t [ drop _ call( node -- ) ] with-cfg-builder ] with-variable
33 GENERIC: emit-node ( block node -- block' )
35 : emit-nodes ( block nodes -- block' )
36 [ over [ emit-node ] [ drop ] if ] each ;
38 : begin-word ( block -- block' )
40 ##safepoint, ##prologue, ##branch,
43 : (build-cfg) ( nodes word label -- )
44 [ begin-word swap emit-nodes drop ] with-cfg-builder ;
46 : build-cfg ( nodes word -- procedures )
53 : emit-loop-call ( successor-block current-block -- )
54 ##safepoint, ##branch,
55 [ swap connect-bbs ] [ end-basic-block ] bi ;
57 : emit-call ( block word height -- block' )
59 2nip swap emit-loop-call f
60 ] [ emit-trivial-call ] if* ;
63 : recursive-height ( #recursive -- n )
64 [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
66 : emit-recursive ( block #recursive -- block' )
67 [ [ label>> id>> ] [ recursive-height ] bi emit-call ] keep
68 [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ;
70 : emit-loop ( block #recursive -- block' )
71 ##branch, [ begin-basic-block ] dip
72 [ label>> id>> loops get set-at ] [ child>> emit-nodes ] 2bi ;
74 M: #recursive emit-node
75 dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
78 : emit-branch ( nodes block -- pair/f )
79 [ swap emit-nodes ] with-branch ;
81 : emit-if ( block node -- block' )
82 children>> over '[ _ emit-branch ] map emit-conditional ;
84 : trivial-branch? ( nodes -- value ? )
86 first dup #push? [ literal>> t ] [ drop f f ] if
89 : trivial-if? ( #if -- ? )
91 [ trivial-branch? [ t eq? ] when ]
92 [ trivial-branch? [ f eq? ] when ] bi*
95 : emit-trivial-if ( -- )
96 [ f cc/= ^^compare-imm ] unary-op ;
98 : trivial-not-if? ( #if -- ? )
100 [ trivial-branch? [ f eq? ] when ]
101 [ trivial-branch? [ t eq? ] when ] bi*
104 : emit-trivial-not-if ( -- )
105 [ f cc= ^^compare-imm ] unary-op ;
107 : emit-actual-if ( block #if -- block' )
108 ! Inputs to the final instruction need to be copied because of
110 ds-pop any-rep ^^copy f cc/= ##compare-imm-branch, emit-if ;
114 { [ dup trivial-if? ] [ drop emit-trivial-if ] }
115 { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
119 M: #dispatch emit-node
120 ! Inputs to the final instruction need to be copied because of
121 ! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
123 ds-pop ^^offset>slot next-vreg ##dispatch, emit-if ;
126 dup word>> dup "intrinsic" word-prop [
127 nip call( block #call -- block' )
128 ] [ swap call-height emit-call ] if* ;
130 M: #call-recursive emit-node
131 [ label>> id>> ] [ call-height ] bi emit-call ;
134 literal>> ^^load-literal ds-push ;
138 ! Even though low level IR has its own dead code elimination pass,
139 ! we try not to introduce useless ##peeks here, since this reduces
140 ! the accuracy of global stack analysis.
142 : make-input-map ( #shuffle -- assoc )
143 [ in-d>> ds-loc ] [ in-r>> rs-loc ] bi
144 [ over length stack-locs zip ] 2bi@ append ;
146 : height-changes ( #shuffle -- height-changes )
147 { [ out-d>> ] [ in-d>> ] [ out-r>> ] [ in-r>> ] } cleave 4array
148 [ length ] map first4 [ - ] 2bi@ 2array ;
150 : store-height-changes ( #shuffle -- )
151 height-changes { ds-loc rs-loc } [ new swap >>n inc-stack ] 2each ;
153 : extract-outputs ( #shuffle -- pair )
154 [ out-d>> ] [ out-r>> ] bi 2array ;
156 : out-vregs/stack ( #shuffle -- pair )
157 [ make-input-map ] [ mapping>> ] [ extract-outputs ] tri
158 [ [ of of peek-loc ] 2with map ] 2with map ;
160 M: #shuffle emit-node
161 [ out-vregs/stack ] keep store-height-changes
162 first2 [ ds-loc store-vregs ] [ rs-loc store-vregs ] bi* ;
165 : end-word ( block -- block' )
166 ##branch, begin-basic-block
168 ##safepoint, ##epilogue, ##return, ;
173 M: #return-recursive emit-node
174 label>> id>> loops get key? [ ] [ end-word ] if ;
177 M: #terminate emit-node
178 drop ##no-tco, end-basic-block f ;
181 M: #introduce emit-node drop ;
183 M: #copy emit-node drop ;
185 M: #enter-recursive emit-node drop ;
187 M: #phi emit-node drop ;
189 M: #declare emit-node drop ;