1 ! Copyright (C) 2009 Slava Pestov
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel fry accessors sequences assocs sets namespaces
4 arrays combinators combinators.short-circuit math make locals
5 deques dlists layouts byte-arrays cpu.architecture
11 compiler.cfg.registers
12 compiler.cfg.instructions
14 compiler.cfg.utilities
15 compiler.cfg.loop-detection
16 compiler.cfg.renaming.functor
17 compiler.cfg.representations.preferred ;
18 IN: compiler.cfg.representations
20 ! Virtual register representation selection.
22 ERROR: bad-conversion dst src dst-rep src-rep ;
24 GENERIC: emit-box ( dst src rep -- )
25 GENERIC: emit-unbox ( dst src rep -- )
27 M:: float-rep emit-box ( dst src rep -- )
28 double-rep next-vreg-rep :> temp
29 temp src ##single>double-float
30 dst temp double-rep emit-box ;
32 M:: float-rep emit-unbox ( dst src rep -- )
33 double-rep next-vreg-rep :> temp
34 temp src double-rep emit-unbox
35 dst temp ##double>single-float ;
37 M: double-rep emit-box
39 [ drop 16 float int-rep next-vreg-rep ##allot ]
40 [ float-offset swap ##set-alien-double ]
43 M: double-rep emit-unbox
44 drop float-offset ##alien-double ;
46 M:: vector-rep emit-box ( dst src rep -- )
47 int-rep next-vreg-rep :> temp
48 dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot
49 temp 16 tag-fixnum ##load-immediate
50 temp dst 1 byte-array tag-number ##set-slot-imm
51 dst byte-array-offset src rep ##set-alien-vector ;
53 M: vector-rep emit-unbox
54 [ byte-array-offset ] dip ##alien-vector ;
56 M:: scalar-rep emit-box ( dst src rep -- )
57 int-rep next-vreg-rep :> temp
58 temp src rep ##scalar>integer
59 dst temp tag-bits get ##shl-imm ;
61 M:: scalar-rep emit-unbox ( dst src rep -- )
62 int-rep next-vreg-rep :> temp
63 temp src tag-bits get ##sar-imm
64 dst temp rep ##integer>scalar ;
66 : emit-conversion ( dst src dst-rep src-rep -- )
68 { [ 2dup eq? ] [ drop ##copy ] }
69 { [ dup int-rep eq? ] [ drop emit-unbox ] }
70 { [ over int-rep eq? ] [ nip emit-box ] }
73 { { double-rep float-rep } [ 2drop ##single>double-float ] }
74 { { float-rep double-rep } [ 2drop ##double>single-float ] }
75 ! Punning SIMD vector types? Naughty naughty! But
76 ! it is allowed... otherwise bail out.
78 drop 2dup [ reg-class-of ] bi@ eq?
79 [ drop ##copy ] [ bad-conversion ] if
87 ! For every vreg, compute possible representations.
90 : possible ( vreg -- reps ) possibilities get at ;
92 : compute-possibilities ( cfg -- )
93 H{ } clone [ '[ swap _ conjoin-at ] with-vreg-reps ] keep
94 [ keys ] assoc-map possibilities set ;
96 ! Compute vregs which must remain tagged for their lifetime.
99 :: (compute-always-boxed) ( vreg rep assoc -- )
101 int-rep vreg assoc set-at
104 : compute-always-boxed ( cfg -- assoc )
108 dup [ ##load-reference? ] [ ##load-constant? ] bi or
109 [ drop ] [ [ _ (compute-always-boxed) ] each-def-rep ] if
114 ! For every vreg, compute the cost of keeping it in every possible
117 ! Cost map maps vreg to representation to cost.
121 possibilities get [ [ 0 ] H{ } map>assoc ] assoc-map costs set ;
123 : increase-cost ( rep vreg -- )
124 ! Increase cost of keeping vreg in rep, making a choice of rep less
126 [ basic-block get loop-nesting-at ] 2dip costs get at at+ ;
128 : maybe-increase-cost ( possible vreg preferred -- )
129 pick eq? [ 2drop ] [ increase-cost ] if ;
131 : representation-cost ( vreg preferred -- )
132 ! 'preferred' is a representation that the instruction can accept with no cost.
133 ! So, for each representation that's not preferred, increase the cost of keeping
134 ! the vreg in that representation.
136 [ '[ _ _ maybe-increase-cost ] ]
139 : compute-costs ( cfg -- costs )
140 init-costs [ representation-cost ] with-vreg-reps costs get ;
142 ! For every vreg, compute preferred representation, that minimizes costs.
143 : minimize-costs ( costs -- representations )
144 [ >alist alist-min first ] assoc-map ;
146 : compute-representations ( cfg -- )
147 [ compute-costs minimize-costs ]
148 [ compute-always-boxed ]
150 representations set ;
152 ! Insert conversions. This introduces new temporaries, so we need
153 ! to rename opearands too.
155 ! Mapping from vreg,rep pairs to vregs
158 :: emit-def-conversion ( dst preferred required -- new-dst' )
159 ! If an instruction defines a register with representation 'required',
160 ! but the register has preferred representation 'preferred', then
161 ! we rename the instruction's definition to a new register, which
162 ! becomes the input of a conversion instruction.
163 dst required next-vreg-rep [ preferred required emit-conversion ] keep ;
165 :: emit-use-conversion ( src preferred required -- new-src' )
166 ! If an instruction uses a register with representation 'required',
167 ! but the register has preferred representation 'preferred', then
168 ! we rename the instruction's input to a new register, which
169 ! becomes the output of a conversion instruction.
170 preferred required eq? [ src ] [
171 src required alternatives get [
172 required next-vreg-rep :> new-src
173 [ new-src ] 2dip preferred emit-conversion
178 SYMBOLS: renaming-set needs-renaming? ;
180 : init-renaming-set ( -- )
182 V{ } clone renaming-set set ;
184 : no-renaming ( vreg -- )
185 dup 2array renaming-set get push ;
187 : record-renaming ( from to -- )
188 2array renaming-set get push needs-renaming? on ;
190 :: (compute-renaming-set) ( vreg required quot: ( vreg preferred required -- ) -- )
191 vreg rep-of :> preferred
192 preferred required eq?
194 [ vreg vreg preferred required quot call record-renaming ] if ; inline
196 : compute-renaming-set ( insn -- )
197 ! temp vregs don't need conversions since they're always in their
198 ! preferred representation
200 [ [ [ emit-use-conversion ] (compute-renaming-set) ] each-use-rep ]
202 [ [ [ emit-def-conversion ] (compute-renaming-set) ] each-def-rep ]
205 : converted-value ( vreg -- vreg' )
206 renaming-set get pop first2 [ assert= ] dip ;
208 RENAMING: convert [ converted-value ] [ converted-value ] [ ]
210 : perform-renaming ( insn -- )
211 needs-renaming? get [
212 renaming-set get reverse-here
213 [ convert-insn-uses ] [ convert-insn-defs ] bi
214 renaming-set get length 0 assert=
217 GENERIC: conversions-for-insn ( insn -- )
221 ! compiler.cfg.cssa inserts conversions which convert phi inputs into
222 ! the representation of the output. However, we still have to do some
223 ! processing here, because if the only node that uses the output of
224 ! the phi instruction is another phi instruction then this phi node's
225 ! output won't have a representation assigned.
226 M: ##phi conversions-for-insn
227 [ , ] [ [ inputs>> values ] [ dst>> ] bi phi-mappings get set-at ] bi ;
229 ! When a literal zeroes/ones vector is unboxed, we replace the ##load-reference
230 ! with a ##zero-vector or ##fill-vector instruction since this is more efficient.
231 : convert-to-zero-vector? ( insn -- ? )
233 [ dst>> rep-of vector-rep? ]
234 [ obj>> B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } = ]
236 : convert-to-fill-vector? ( insn -- ? )
238 [ dst>> rep-of vector-rep? ]
239 [ obj>> B{ 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 } = ]
242 : (convert-to-zero/fill-vector) ( insn -- dst rep )
243 dst>> dup rep-of ; inline
245 : conversions-for-load-insn ( insn -- ?insn )
248 [ dup convert-to-zero-vector? ]
249 [ (convert-to-zero/fill-vector) ##zero-vector f ]
252 [ dup convert-to-fill-vector? ]
253 [ (convert-to-zero/fill-vector) ##fill-vector f ]
258 M: ##load-reference conversions-for-insn
259 conversions-for-load-insn [ call-next-method ] when* ;
261 M: ##load-constant conversions-for-insn
262 conversions-for-load-insn [ call-next-method ] when* ;
264 M: vreg-insn conversions-for-insn
265 [ compute-renaming-set ] [ perform-renaming ] bi ;
267 M: insn conversions-for-insn , ;
269 : conversions-for-block ( bb -- )
270 dup kill-block? [ drop ] [
273 H{ } clone alternatives set
274 [ conversions-for-insn ] each
276 ] change-instructions drop
279 ! If the output of a phi instruction is only used as the input to another
280 ! phi instruction, then we want to use the same representation for both
284 : add-to-work-list ( vregs -- )
285 work-list get push-all-front ;
287 : rep-assigned ( vregs -- vregs' )
288 representations get '[ _ key? ] filter ;
290 : rep-not-assigned ( vregs -- vregs' )
291 representations get '[ _ key? not ] filter ;
293 : add-ready-phis ( -- )
294 phi-mappings get keys rep-assigned add-to-work-list ;
296 : process-phi-mapping ( dst -- )
297 ! If dst = phi(src1,src2,...) and dst's representation has been
298 ! determined, assign that representation to each one of src1,...
299 ! that does not have a representation yet, and process those, too.
300 dup phi-mappings get at* [
301 [ rep-of ] [ rep-not-assigned ] bi*
302 [ [ set-rep-of ] with each ] [ add-to-work-list ] bi
305 : remaining-phi-mappings ( -- )
306 phi-mappings get keys rep-not-assigned
307 [ [ int-rep ] dip set-rep-of ] each ;
309 : process-phi-mappings ( -- )
310 <hashed-dlist> work-list set
312 work-list get [ process-phi-mapping ] slurp-deque
313 remaining-phi-mappings ;
315 : insert-conversions ( cfg -- )
316 H{ } clone phi-mappings set
317 [ conversions-for-block ] each-basic-block
318 process-phi-mappings ;
322 : select-representations ( cfg -- cfg' )
326 [ compute-possibilities ]
327 [ compute-representations ]
328 [ insert-conversions ]
331 representations get cfg get (>>reps) ;