1 ! Copyright (C) 2004, 2010 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators compiler.cfg
4 compiler.cfg.builder.blocks compiler.cfg.comparisons
5 compiler.cfg.hats compiler.cfg.instructions
6 compiler.cfg.registers compiler.cfg.stacks
7 compiler.cfg.stacks.local compiler.cfg.utilities compiler.tree
8 cpu.architecture kernel make math namespaces sequences words ;
9 IN: compiler.cfg.builder
16 : begin-cfg ( word label -- cfg )
18 <basic-block> dup set-basic-block <cfg> dup cfg set ;
20 : with-cfg-builder ( nodes word label quot: ( ..a block -- ..b ) -- )
24 [ procedures get push ]
26 [ end-stack-analysis ] tri
29 : with-dummy-cfg-builder ( node quot -- )
31 [ V{ } clone procedures ] 2dip
32 '[ _ t t [ drop _ call( node -- ) ] with-cfg-builder ] with-variable
35 GENERIC: emit-node ( block node -- block' )
37 : emit-nodes ( block nodes -- block' )
38 [ over [ emit-node ] [ drop ] if ] each ;
40 : begin-word ( block -- block' )
42 ##safepoint, ##prologue, ##branch,
45 : (build-cfg) ( nodes word label -- )
46 [ begin-word swap emit-nodes drop ] with-cfg-builder ;
48 : build-cfg ( nodes word -- procedures )
55 : emit-loop-call ( successor-block current-block -- )
56 ##safepoint, ##branch,
57 [ swap connect-bbs ] [ end-basic-block ] bi ;
59 : emit-call ( block word height -- block' )
61 2nip swap emit-loop-call f
62 ] [ emit-trivial-call ] if* ;
65 : recursive-height ( #recursive -- n )
66 [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
68 : emit-recursive ( block #recursive -- block' )
69 [ [ label>> id>> ] [ recursive-height ] bi emit-call ] keep
70 [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ;
72 : emit-loop ( block #recursive -- block' )
73 ##branch, [ begin-basic-block ] dip
74 [ label>> id>> loops get set-at ] [ child>> emit-nodes ] 2bi ;
76 M: #recursive emit-node
77 dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
80 : emit-branch ( nodes block -- pair/f )
81 [ swap emit-nodes ] with-branch ;
83 : emit-if ( block node -- block' )
84 children>> over '[ _ emit-branch ] map emit-conditional ;
86 : trivial-branch? ( nodes -- value ? )
88 first dup #push? [ literal>> t ] [ drop f f ] if
91 : trivial-if? ( #if -- ? )
93 [ trivial-branch? [ t eq? ] when ]
94 [ trivial-branch? [ f eq? ] when ] bi*
97 : emit-trivial-if ( -- )
98 [ f cc/= ^^compare-imm ] unary-op ;
100 : trivial-not-if? ( #if -- ? )
102 [ trivial-branch? [ f eq? ] when ]
103 [ trivial-branch? [ t eq? ] when ] bi*
106 : emit-trivial-not-if ( -- )
107 [ f cc= ^^compare-imm ] unary-op ;
109 : emit-actual-if ( block #if -- block' )
110 ! Inputs to the final instruction need to be copied because of
112 ds-pop any-rep ^^copy f cc/= ##compare-imm-branch, emit-if ;
116 { [ dup trivial-if? ] [ drop emit-trivial-if ] }
117 { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
121 M: #dispatch emit-node
122 ! Inputs to the final instruction need to be copied because of
123 ! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
125 ds-pop ^^offset>slot next-vreg ##dispatch, emit-if ;
128 dup word>> dup "intrinsic" word-prop [
129 nip call( block #call -- block' )
130 ] [ swap call-height emit-call ] if* ;
132 M: #call-recursive emit-node
133 [ label>> id>> ] [ call-height ] bi emit-call ;
136 literal>> ^^load-literal ds-push ;
140 ! Even though low level IR has its own dead code elimination pass,
141 ! we try not to introduce useless ##peeks here, since this reduces
142 ! the accuracy of global stack analysis.
144 : make-input-map ( #shuffle -- assoc )
145 [ in-d>> ds-loc ] [ in-r>> rs-loc ] bi
146 [ over length stack-locs zip ] 2bi@ append ;
148 : height-changes ( #shuffle -- height-changes )
149 { [ out-d>> ] [ in-d>> ] [ out-r>> ] [ in-r>> ] } cleave 4array
150 [ length ] map first4 [ - ] 2bi@ 2array ;
152 : store-height-changes ( #shuffle -- )
153 height-changes { ds-loc rs-loc } [ new swap >>n inc-stack ] 2each ;
155 : extract-outputs ( #shuffle -- pair )
156 [ out-d>> ] [ out-r>> ] bi 2array ;
158 : out-vregs/stack ( #shuffle -- pair )
159 [ make-input-map ] [ mapping>> ] [ extract-outputs ] tri
160 [ [ of of peek-loc ] 2with map ] 2with map ;
162 M: #shuffle emit-node
163 [ out-vregs/stack ] keep store-height-changes
164 first2 [ ds-loc store-vregs ] [ rs-loc store-vregs ] bi* ;
167 : end-word ( block -- block' )
168 ##branch, begin-basic-block
170 ##safepoint, ##epilogue, ##return, ;
175 M: #return-recursive emit-node
176 label>> id>> loops get key? [ ] [ end-word ] if ;
179 M: #terminate emit-node
180 drop ##no-tco, end-basic-block f ;
183 M: #introduce emit-node drop ;
185 M: #copy emit-node drop ;
187 M: #enter-recursive emit-node drop ;
189 M: #phi emit-node drop ;
191 M: #declare emit-node drop ;