Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /MLRISC/trunk/amd64/mltree/amd64-gen.sml
ViewVC logotype

Annotation of /MLRISC/trunk/amd64/mltree/amd64-gen.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2631 - (view) (download)

1 : mrainey 2619 (* amd64-gen.sml
2 :     *
3 :     * Translate MLRISC trees into AMD64 instructions.
4 :     *)
5 :    
6 :     functor AMD64Gen (
7 :     structure I : AMD64INSTR
8 :     structure MLTreeUtils : MLTREE_UTILS
9 :     where T = I.T
10 :     structure ExtensionComp : MLTREE_EXTENSION_COMP
11 :     where I = I and T = I.T) : MLTREECOMP =
12 :     struct
13 :    
14 :     structure TS = ExtensionComp.TS
15 :     structure T = I.T
16 :     structure I = I
17 :     structure CFG = ExtensionComp.CFG
18 :     structure C = I.C
19 :     structure CB = CellsBasis
20 :     structure A = MLRiscAnnotations
21 :     structure TRS = MLTreeSize (structure T = T
22 :     val intTy = 64)
23 :     structure Shuffle = Shuffle (I)
24 :     structure O = AMD64Opcodes (structure I = I)
25 :     structure Gen = MLTreeGen (
26 :     structure T = T
27 :     structure Cells = C
28 :     val intTy = 64
29 :     val naturalWidths = [32, 64]
30 :     datatype rep = SE | ZE | NEITHER
31 :     val rep = NEITHER)
32 :     structure W32 = Word32
33 :    
34 :    
35 :     fun error msg = MLRiscErrorMsg.error ("AMD64Gen", msg)
36 :    
37 :     type instrStream = (I.instruction,C.cellset,CFG.cfg) TS.stream
38 :     type mltreeStream = (T.stm,T.mlrisc list,CFG.cfg) TS.stream
39 :    
40 :     (* label where a trap is generated -- one per cluster *)
41 :     val trapLabel = ref (NONE: (I.instruction * Label.label) option)
42 :    
43 :     (* flag floating point generation *)
44 :     val floatingPointUsed = ref false
45 :    
46 :     fun gpr (ty, r) = I.Direct (ty, r)
47 :     val fpr = I.FDirect
48 :    
49 :     fun rax ty = I.Direct(ty,C.rax)
50 :     fun rcx ty = I.Direct(ty,C.rcx)
51 :     fun rdx ty = I.Direct(ty,C.rdx)
52 :    
53 :     val readonly = I.Region.readonly
54 :    
55 :     val newReg = C.newReg
56 :     val newFreg = C.newFreg
57 :    
58 :     (* convert mlrisc to cellset: *)
59 :     fun cellset mlrisc = let
60 :     val addCCReg = CB.CellSet.add
61 :     fun g([],acc) = acc
62 :     | g(T.GPR(T.REG(_,r))::regs,acc) = g(regs,C.addReg(r,acc))
63 :     | g(T.FPR(T.FREG(_,f))::regs,acc) = g(regs,C.addFreg(f,acc))
64 :     | g(T.CCR(T.CC(_,cc))::regs,acc) = g(regs,addCCReg(cc,acc))
65 :     | g(T.CCR(T.FCC(_,cc))::regs,acc) = g(regs,addCCReg(cc,acc))
66 :     | g(_::regs, acc) = g(regs, acc)
67 :     in
68 :     g(mlrisc, C.empty)
69 :     end
70 :    
71 :     (* conversions *)
72 :     val itow = Word.fromInt
73 :     val wtoi = Word.toInt
74 :     fun toInt32 i = T.I.toInt32(32, i)
75 :     val w32toi32 = Word32.toLargeIntX
76 :     val i32tow32 = Word32.fromLargeInt
77 :     (* One day, this is going to bite us when precision(LargeInt)>32 *)
78 :     fun wToInt32 w = Int32.fromLarge(Word32.toLargeIntX w)
79 :    
80 :     (* analyze for power-of-two-ness *)
81 :     fun analyze i' = let
82 :     val i = toInt32 i'
83 :     in
84 :     let val (isneg, a, w) =
85 :     if i >= 0 then (false, i, T.I.toWord32 (32, i'))
86 :     else (true, ~i, T.I.toWord32 (32, T.I.NEG (32, i')))
87 :     fun log2 (0w1, p) = p
88 :     | log2 (w, p) = log2 (W32.>> (w, 0w1), p + 1)
89 :     in
90 :     if w > 0w1 andalso W32.andb (w - 0w1, w) = 0w0 then
91 :     (i, SOME (isneg, a,
92 :     T.LI (T.I.fromInt32 (32, log2 (w, 0)))))
93 :     else (i, NONE)
94 :     end handle _ => (i, NONE)
95 :     end
96 :    
97 :     fun immedLabel lab = I.ImmedLabel(T.LABEL lab)
98 :    
99 :     (* translate MLTREE condition codes to amd64 condition codes *)
100 :     fun cond T.LT = I.LT | cond T.LTU = I.B
101 :     | cond T.LE = I.LE | cond T.LEU = I.BE
102 :     | cond T.EQ = I.EQ | cond T.NE = I.NE
103 :     | cond T.GE = I.GE | cond T.GEU = I.AE
104 :     | cond T.GT = I.GT | cond T.GTU = I.A
105 :     | cond cc = error(concat["cond(", T.Basis.condToString cc, ")"])
106 :    
107 :     (* Is the expression zero? *)
108 :     fun isZero(T.LI z) = z = 0
109 :     | isZero(T.MARK(e,a)) = isZero e
110 :     | isZero _ = false
111 :     fun setZeroBit(T.ANDB _) = true
112 :     | setZeroBit(T.ORB _) = true
113 :     | setZeroBit(T.XORB _) = true
114 :     | setZeroBit(T.SRA _) = true
115 :     | setZeroBit(T.SRL _) = true
116 :     | setZeroBit(T.SLL _) = true
117 :     | setZeroBit(T.SUB _) = true
118 :     | setZeroBit(T.ADDT _) = true
119 :     | setZeroBit(T.SUBT _) = true
120 :     | setZeroBit(T.MARK(e, _)) = setZeroBit e
121 :     | setZeroBit _ = false
122 :    
123 :     fun setZeroBit2(T.ANDB _) = true
124 :     | setZeroBit2(T.ORB _) = true
125 :     | setZeroBit2(T.XORB _) = true
126 :     | setZeroBit2(T.SRA _) = true
127 :     | setZeroBit2(T.SRL _) = true
128 :     | setZeroBit2(T.SLL _) = true
129 :     | setZeroBit2(T.ADD(_, _, _)) = true (* can't use leal! *)
130 :     | setZeroBit2(T.SUB _) = true
131 :     | setZeroBit2(T.ADDT _) = true
132 :     | setZeroBit2(T.SUBT _) = true
133 :     | setZeroBit2(T.MARK(e, _)) = setZeroBit2 e
134 :     | setZeroBit2 _ = false
135 :    
136 :     and isMemOpnd opnd = (case opnd
137 :     of I.Displace _ => true
138 :     | I.Indexed _ => true
139 :     | I.LabelEA _ => true
140 :     | I.FDirect f => true
141 :     | _ => false
142 :     (* end case *))
143 :    
144 :     fun selectInstructions (TS.S.STREAM{
145 :     emit=emitInstr, defineLabel, entryLabel, pseudoOp, annotation,
146 :     getAnnotations, beginCluster, endCluster, exitBlock,
147 :     comment, ...}) = let
148 :     val emit = emitInstr o I.INSTR
149 :     val emits = app emitInstr
150 :     (* mark an expression with a list of annotations *)
151 :     fun mark' (i, []) = emitInstr i
152 :     | mark' (i, a::an) = mark'(I.ANNOTATION{i=i,a=a},an)
153 :     (* annotate an expression and emit it *)
154 :     fun mark (i, an) = mark' (I.INSTR i, an)
155 :    
156 :     (* move with annotation *)
157 :     fun move' (ty, dst as I.Direct (_, s), src as I.Direct (_, d), an) =
158 :     if CB.sameColor (s, d)
159 :     then ()
160 :     else mark' (I.COPY {k=CB.GP, sz=ty, src=[s], dst=[d], tmp=NONE}, an)
161 :     | move' (ty, I.Immed 0, dst, an) =
162 :     mark' (I.binary {binOp=O.xorOp ty, src=dst, dst=dst}, an)
163 :     | move' (ty, src, dst, an) =
164 :     mark' (I.move {mvOp=O.movOp ty, src=src, dst=dst}, an)
165 :     (* move with annotation *)
166 :     fun move (ty, src, dst) = move' (ty, src, dst, [])
167 :    
168 :     fun zero (ty, dst) = emit (I.BINARY{binOp=O.xorOp ty, src=dst, dst=dst})
169 :    
170 :     fun copy (ty, [], [], an) = ()
171 :     | copy (ty, dst, src, an) = let
172 :     fun mvInstr {dst=I.Direct (_,rd), src=I.Direct (_,rs)} =
173 :     if CB.sameColor (rd, rs)
174 :     then []
175 :     else [I.COPY {k=CB.GP, sz=ty, dst=[rd], src=[rs], tmp=NONE}]
176 :     | mvInstr {dst, src} = [I.move {mvOp=O.movOp ty, src=src, dst=dst}]
177 :     val stms = Shuffle.shuffle {mvInstr=mvInstr, ea=fn r => gpr (ty, r)}
178 :     {tmp=SOME (I.Direct (ty, newReg ())), dst=dst, src=src}
179 :     in
180 :     emits stms
181 :     end (* copy *)
182 :    
183 :     (* Add an overflow trap *)
184 :     fun trap() = let
185 :     val jmp = (case !trapLabel
186 :     of NONE => let
187 :     val label = Label.label "trap" ()
188 :     val jmp = I.ANNOTATION{i=I.jcc{cond=I.O,
189 :     opnd=I.ImmedLabel(T.LABEL label)},
190 :     a=MLRiscAnnotations.BRANCHPROB (Probability.unlikely)}
191 :     in
192 :     trapLabel := SOME(jmp, label);
193 :     jmp
194 :     end
195 :     | SOME(jmp, _) => jmp
196 :     (* end case *))
197 :     in
198 :     emitInstr jmp
199 :     end (* trap *)
200 :    
201 :     exception EA
202 :    
203 :     fun address' ty (ea, mem) = let
204 :     fun makeAddressingMode (NONE, NONE, _, disp) = disp
205 :     | makeAddressingMode(SOME base, NONE, _, disp) =
206 :     I.Displace{base=base, disp=disp, mem=mem}
207 :     | makeAddressingMode(base, SOME index, scale, disp) =
208 :     I.Indexed{base=base, index=index, scale=scale,
209 :     disp=disp, mem=mem}
210 :    
211 :     (* Keep building a bigger and bigger effective address expressions
212 :     * The input is a list of trees
213 :     * b -- base
214 :     * i -- index
215 :     * s -- scale
216 :     * d -- immed displacement
217 :     *)
218 :     fun doEA([], b, i, s, d) = makeAddressingMode(b, i, s, d)
219 :     | doEA(t::trees, b, i, s, d) = (case t
220 :     of T.LI n => doEAImmed(trees, toInt32 n, b, i, s, d)
221 :     | T.CONST _ => doEALabel(trees, t, b, i, s, d)
222 :     | T.LABEL _ => doEALabel(trees, t, b, i, s, d)
223 :     | T.LABEXP le => doEALabel(trees, le, b, i, s, d)
224 :     | T.ADD(ty, t1, t2 as T.REG(_,r)) =>
225 :     doEA(t1::t2::trees, b, i, s, d)
226 :     | T.ADD(ty, t1, t2) => doEA(t1::t2::trees, b, i, s, d)
227 :     | T.SUB(ty, t1, T.LI n) =>
228 :     doEA(t1::T.LI(T.I.NEG(ty,n))::trees, b, i, s, d)
229 :     | T.SLL(ty, t1, T.LI n) => let
230 :     val n = T.I.toInt(ty, n)
231 :     in
232 :     case n
233 :     of 0 => displace(trees, t1, b, i, s, d)
234 :     | 1 => indexed(trees, t1, t, 1, b, i, s, d)
235 :     | 2 => indexed(trees, t1, t, 2, b, i, s, d)
236 :     | 3 => indexed(trees, t1, t, 3, b, i, s, d)
237 :     | _ => displace(trees, t, b, i, s, d)
238 :     end
239 :     | t => displace(trees, t, b, i, s, d)
240 :     (* esac *))
241 :    
242 :     (* Add an immed constant *)
243 :     and doEAImmed(trees, 0, b, i, s, d) = doEA(trees, b, i, s, d)
244 :     | doEAImmed(trees, n, b, i, s, I.Immed m) =
245 :     doEA(trees, b, i, s, I.Immed(n+m))
246 :     | doEAImmed(trees, n, b, i, s, I.ImmedLabel le) =
247 :     doEA(trees, b, i, s,
248 :     I.ImmedLabel(T.ADD(ty,le,T.LI(T.I.fromInt32(ty, n)))))
249 :     | doEAImmed(trees, n, b, i, s, _) = error "doEAImmed"
250 :    
251 :     (* Add a label expression *)
252 :     and doEALabel(trees, le, b, i, s, I.Immed 0) =
253 :     doEA(trees, b, i, s, I.ImmedLabel le)
254 :     | doEALabel(trees, le, b, i, s, I.Immed m) =
255 :     doEA(trees, b, i, s,
256 :     I.ImmedLabel(T.ADD(ty,le,T.LI(T.I.fromInt32(ty, m))))
257 :     handle Overflow => error "doEALabel: constant too large")
258 :     | doEALabel(trees, le, b, i, s, I.ImmedLabel le') =
259 :     doEA(trees, b, i, s, I.ImmedLabel(T.ADD(ty,le,le')))
260 :     | doEALabel(trees, le, b, i, s, _) = error "doEALabel"
261 :    
262 :     (* generate code for tree and ensure that it is not in %rsp *)
263 :     and exprNotRsp tree = let
264 :     val r = genExpr tree
265 :     in
266 :     if CB.sameColor(r, C.rsp) then let
267 :     val tmp = newReg()
268 :     in
269 :     move(ty, I.Direct (ty,r), I.Direct (ty,tmp));
270 :     tmp
271 :     end
272 :     else r
273 :     end
274 :    
275 :     (* Add a base register *)
276 :     and displace(trees, t, NONE, i, s, d) = (* no base yet *)
277 :     doEA(trees, SOME(genExpr t), i, s, d)
278 :     | displace(trees, t, b as SOME base, NONE, _, d) = (* no index *)
279 :     (* make t the index, but make sure that it is not %rsp! *)
280 :     let val i = genExpr t
281 :     in if CB.sameColor(i, C.rsp) then
282 :     (* swap base and index *)
283 :     if CB.sameColor(base, C.rsp) then
284 :     doEA(trees, SOME i, b, 0, d)
285 :     else (* base and index = %rsp! *)
286 :     let val index = newReg()
287 :     in
288 :     move(ty, I.Direct (ty,i), I.Direct (ty,index));
289 :     doEA(trees, b, SOME index, 0, d)
290 :     end
291 :     else doEA(trees, b, SOME i, 0, d)
292 :     end
293 :     | displace(trees, t, SOME base, i, s, d) = (* base and index *)
294 :     let val b = genExpr (T.ADD(ty,T.REG(ty,base),t))
295 :     in
296 :     doEA(trees, SOME b, i, s, d)
297 :     end
298 :    
299 :     (* Add an indexed register *)
300 :     and indexed(trees, t, t0, scale, b, NONE, _, d) = (* no index yet *)
301 :     doEA(trees, b, SOME(exprNotRsp t), scale, d)
302 :     | indexed(trees, _, t0, _, NONE, i, s, d) = (* no base *)
303 :     doEA(trees, SOME(genExpr t0), i, s, d)
304 :     | indexed(trees, _, t0, _, SOME base, i, s, d) = (*base and index*)
305 :     let val b = genExpr (T.ADD(ty, t0, T.REG(ty, base)))
306 :     in
307 :     doEA(trees, SOME b, i, s, d)
308 :     end
309 :     in
310 :     case doEA ([ea], NONE, NONE, 0, I.Immed 0)
311 :     of I.Immed _ => raise EA
312 :     | I.ImmedLabel le => I.LabelEA le
313 :     | ea => ea
314 :     end (* address' *)
315 :    
316 :     and address (ea, mem) = address' 64 (ea, mem)
317 :    
318 :     (* reduce an expression into an operand *)
319 :     and operand ty (T.LI i) = I.Immed (toInt32 i)
320 :     | operand _ (x as (T.CONST _ | T.LABEL _)) = I.ImmedLabel x
321 :     | operand _ (T.LABEXP le) = I.ImmedLabel le
322 :     | operand _ (T.REG(ty,r)) = gpr (ty, r)
323 :     | operand _ (T.LOAD(ty,ea,mem)) = address (ea, mem)
324 :     | operand ty t = I.Direct(ty, genExpr t)
325 :    
326 :     (* ensure that the operand is either an immed or register *)
327 :     and immedOrReg(ty, opnd as I.Displace _) = moveToReg (ty, opnd)
328 :     | immedOrReg(ty, opnd as I.Indexed _) = moveToReg (ty, opnd)
329 :     | immedOrReg(ty, opnd as I.LabelEA _) = moveToReg (ty, opnd)
330 :     | immedOrReg (ty, opnd) = opnd
331 :    
332 :     and regOrMem (ty, opnd) =
333 :     if isImmediate opnd then moveToReg (ty, opnd) else opnd
334 :    
335 :     and getExpr (exp as T.REG(_, rd)) = rd
336 :     | getExpr exp = genExpr exp
337 :    
338 :     and moveToReg (ty, opnd) = let
339 :     val dst = I.Direct (ty, newReg ())
340 :     in
341 :     move (ty, opnd, dst);
342 :     dst
343 :     end
344 :    
345 :     and isImmediate(I.Immed _) = true
346 :     | isImmediate(I.ImmedLabel _) = true
347 :     | isImmediate _ = false
348 :    
349 :     and genExpr' e = let
350 :     val r = newReg ()
351 :     in
352 :     expr (e, r, []);
353 :     r
354 :     end
355 :     (* generate an expression, and return its result in a register *)
356 :     and genExpr (T.REG (_, r)) = r
357 :     | genExpr e = genExpr' e
358 :    
359 :     and expr' (ty, e, dst, an) = let
360 :     val dstOpnd = gpr (ty, dst)
361 :     fun equalDst (I.Direct (_,r)) = CB.sameColor(r, dst)
362 :     | equalDst _ = false
363 :     fun dstMustBeReg f = f (dst, dstOpnd)
364 :     fun genLoad (mvOp, ea, mem) = dstMustBeReg (fn (ty, dst) =>
365 :     mark (I.MOVE {mvOp=mvOp, src=address (ea, mem), dst=dst},an))
366 :     fun unknownExp exp = expr (Gen.compileRexp exp, dst, an)
367 :    
368 :     (* Generate a unary operator *)
369 :     fun unary(ty, unOp, e) = let
370 :     val opnd = operand ty e
371 :     in
372 :     if isMemOpnd opnd then let
373 :     val tmp = I.Direct(ty, newReg())
374 :     in
375 :     move(ty, opnd, tmp);
376 :     move(ty, tmp, dstOpnd)
377 :     end
378 :     else move(ty, opnd, dstOpnd);
379 :     mark(I.UNARY{unOp=unOp ty, opnd=dstOpnd}, an)
380 :     end
381 :    
382 :     fun genBinary (ty, binOp, opnd1, opnd2) =
383 :     if (isMemOpnd opnd1 orelse isMemOpnd opnd2) orelse
384 :     equalDst(opnd2) then let
385 :     val tmpR = newReg()
386 :     val tmp = I.Direct (ty,tmpR)
387 :     in
388 :     move (ty, opnd1, tmp);
389 :     mark (I.BINARY{binOp=binOp ty, src=opnd2, dst=tmp}, an);
390 :     move (ty, tmp, dstOpnd)
391 :     end
392 :     else (move (ty, opnd1, dstOpnd);
393 :     mark(I.BINARY{binOp=binOp ty, src=opnd2, dst=dstOpnd}, an))
394 :     (* generate a binary operator that may commute *)
395 :     fun binaryComm (ty, binOp, e1, e2) = let
396 :     val (opnd1, opnd2) = (case (operand ty e1, operand ty e2)
397 :     of (x as I.Immed _, y) => (y, x)
398 :     | (x as I.ImmedLabel _, y) => (y, x)
399 :     | (x, y as I.Direct _) => (y, x)
400 :     | (x, y) => (x, y)
401 :     (* end case *))
402 :     in
403 :     genBinary(ty, binOp, opnd1, opnd2)
404 :     end
405 :     (* Generate a binary operator; non-commutative *)
406 :     fun binary(ty, binOp, e1, e2) =
407 :     genBinary(ty, binOp, operand ty e1, operand ty e2)
408 :     (* Add n to dst *)
409 :     fun addN (addOp, n) = let
410 :     val n = operand ty n
411 :     in
412 :     mark (I.BINARY{binOp=addOp, src=n, dst=dstOpnd}, an)
413 :     end
414 :     (* Generate addition *)
415 :     fun addition(ty, e1, e2) = (case e1
416 :     of T.REG(_,rs) =>
417 :     if CB.sameColor(rs,dst)
418 :     then addN (O.addOp ty, e2)
419 :     else addition1 (ty, e1,e2)
420 :     | _ => addition1(ty, e1,e2)
421 :     (* end case *))
422 :     and addition1 (ty, e1, e2) = (case e2
423 :     of T.REG(_,rs) =>
424 :     if CB.sameColor(rs,dst)
425 :     then addN (O.addOp ty, e1)
426 :     else addition2(ty, e1,e2)
427 :     | _ => addition2 (ty, e1,e2)
428 :     (* end case *))
429 :     and addition2 (ty, e1, e2) =
430 :     (dstMustBeReg(fn (dstR, _) => (case ty
431 :     of 32 => mark(I.LEAL{r32=dstR,
432 :     addr=address' 32 (e, readonly)}, an)
433 :     | 64 => mark(I.LEAQ{r64=dstR,
434 :     addr=address' 64 (e, readonly)}, an)
435 :     (* end case*)))
436 :     handle EA => binaryComm(ty, O.addOp, e1, e2))
437 :    
438 :     (* the shift amount must be a constant or in %rcx *)
439 :     fun shift(ty, opcode, e1, e2) = let
440 :     val (opnd1, opnd2) = (operand ty e1, operand ty e2)
441 :     in
442 :     (case opnd2
443 :     of I.Immed _ => genBinary(ty, opcode, opnd1, opnd2)
444 :     | _ =>
445 :     if equalDst(opnd2) then
446 :     let val tmpR = newReg()
447 :     val tmp = I.Direct (ty,tmpR)
448 :     in
449 :     move(ty, opnd1, tmp);
450 :     move(ty, opnd2, rcx ty);
451 :     mark(I.BINARY{binOp=opcode ty, src=rcx ty,
452 :     dst=tmp},an);
453 :     move(ty, tmp, dstOpnd)
454 :     end
455 :     else
456 :     (move(ty, opnd1, dstOpnd);
457 :     move(ty, opnd2, rcx ty);
458 :     mark(I.BINARY{binOp=opcode ty, src=rcx ty,
459 :     dst=dstOpnd},an))
460 :     (* end case *))
461 :     end
462 :    
463 :     (* division with rounding towards negative infinity *)
464 :     fun divinf0 (ty, overflow, e1, e2) = let
465 :     val o1 = operand ty e1
466 :     val o2 = operand ty e2
467 :     val l = Label.anon ()
468 :     in
469 :     move (ty, o1, rax ty);
470 :     emit I.CDQ;
471 :     mark (I.MULTDIV { multDivOp = O.idivOp ty,
472 :     src = regOrMem (ty, o2) },
473 :     an);
474 :     if overflow then trap() else ();
475 :     app emit [(O.cmpOp ty) { lsrc = rdx ty, rsrc = I.Immed 0 },
476 :     I.JCC { cond = I.EQ, opnd = immedLabel l },
477 :     I.BINARY { binOp = O.xorOp ty,
478 :     src = regOrMem (ty, o2),
479 :     dst = rdx ty },
480 :     I.JCC { cond = I.GE, opnd = immedLabel l },
481 :     I.UNARY { unOp = O.decOp ty, opnd = rax ty }];
482 :     defineLabel l;
483 :     move (ty, rax ty, dstOpnd)
484 :     end
485 :    
486 :     (* Division by a power of two when rounding to neginf is the
487 :     * same as an arithmetic right shift. *)
488 :     fun divinf (ty, overflow, e1, e2 as T.LI n') =
489 :     (case analyze n' of
490 :     (_, NONE) => divinf0 (ty, overflow, e1, e2)
491 :     | (_, SOME (false, _, p)) =>
492 :     shift (ty, O.sarOp, T.REG (ty, getExpr e1), p)
493 :     | (_, SOME (true, _, p)) => let
494 :     val reg = getExpr e1
495 :     in
496 :     emit(I.UNARY { unOp = O.negOp ty,
497 :     opnd = I.Direct (ty,reg) });
498 :     shift (ty, O.sarOp, T.REG (ty, reg), p)
499 :     end)
500 :     | divinf (ty, overflow, e1, e2) = divinf0 (ty, overflow, e1, e2)
501 :    
502 :     fun reminf0 (ty, e1, e2) = let
503 :     val o1 = operand ty e1
504 :     val o2 = operand ty e2
505 :     val l = Label.anon ()
506 :     in
507 :     move (ty, o1, rax ty);
508 :     emit I.CDQ;
509 :     mark (I.MULTDIV { multDivOp = O.idiv1Op ty,
510 :     src = regOrMem (ty, o2) },
511 :     an);
512 :     app emit [(O.cmpOp ty) { lsrc = rdx ty, rsrc = I.Immed 0 },
513 :     I.JCC { cond = I.EQ, opnd = immedLabel l }];
514 :     move (ty, rdx ty, rax ty);
515 :     app emit [I.BINARY { binOp = O.xorOp ty,
516 :     src = regOrMem (ty, o2), dst = rax ty },
517 :     I.JCC { cond = I.GE, opnd = immedLabel l },
518 :     I.BINARY { binOp = O.addOp ty,
519 :     src = regOrMem (ty, o2), dst = rdx ty }];
520 :     defineLabel l;
521 :     move (ty, rdx ty, dstOpnd)
522 :     end
523 :    
524 :     (* n mod (power-of-2) corrrsponds to a bitmask (AND).
525 :     * If the power is negative, then we must first negate
526 :     * the argument and then again negate the result. *)
527 :     fun reminf (ty, e1, e2 as T.LI n') =
528 :     (case analyze n' of
529 :     (_, NONE) => reminf0 (ty, e1, e2)
530 :     | (_, SOME (false, a, _)) =>
531 :     binaryComm (ty, O.andOp, e1,
532 :     T.LI (T.I.fromInt32 (ty, a - 1)))
533 :     | (_, SOME (true, a, _)) => let
534 :     val r1 = getExpr e1
535 :     val o1 = I.Direct (ty,r1)
536 :     in
537 :     emit (I.UNARY { unOp = O.negOp ty, opnd = o1 });
538 :     emit (I.BINARY { binOp = O.andOp ty,
539 :     src = I.Immed (a - 1),
540 :     dst = o1 });
541 :     unary (ty, O.negOp, T.REG (ty, r1))
542 :     end)
543 :     | reminf (ty, e1, e2) = reminf0 (ty, e1, e2)
544 :    
545 :     (* Division or remainder: divisor must be in %rdx:%rax pair *)
546 :     fun divrem(ty, signed, overflow, e1, e2, resultReg) =
547 :     let val (opnd1, opnd2) = (operand ty e1, operand ty e2)
548 :     val _ = move(ty, opnd1, rax ty)
549 :     val oper = if signed then (emit(I.CDQ); O.idiv1Op ty)
550 :     else (zero (ty, rdx ty); O.div1Op ty)
551 :     in mark(I.MULTDIV{multDivOp=oper, src=regOrMem (ty, opnd2)},an);
552 :     move(ty, resultReg, dstOpnd);
553 :     if overflow then trap() else ()
554 :     end
555 :    
556 :     (* Optimize the special case for division *)
557 :     fun divide (ty, signed, overflow, e1, e2 as T.LI n') =
558 :     (case analyze n' of
559 :     (n, SOME (isneg, a, p)) =>
560 :     if signed then
561 :     let val label = Label.anon ()
562 :     val reg1 = getExpr e1
563 :     val opnd1 = I.Direct (ty,reg1)
564 :     in
565 :     if isneg then
566 :     emit (I.UNARY { unOp = O.negOp ty,
567 :     opnd = opnd1 })
568 :     else if setZeroBit e1 then ()
569 :     else emit (O.cmpOp ty { lsrc = opnd1,
570 :     rsrc = I.Immed 0 });
571 :     emit (I.JCC { cond = I.GE,
572 :     opnd = immedLabel label });
573 :     emit (if a = 2 then
574 :     I.UNARY { unOp = O.incOp ty,
575 :     opnd = opnd1 }
576 :     else
577 :     I.BINARY { binOp = O.addOp ty,
578 :     src = I.Immed (a - 1),
579 :     dst = opnd1 });
580 :     defineLabel label;
581 :     shift (ty, O.sarOp, T.REG (ty, reg1), p)
582 :     end
583 :     else shift (ty, O.shrOp, e1, p)
584 :     | (n, NONE) =>
585 :     divrem(ty, signed, overflow andalso (n = ~1 orelse n = 0),
586 :     e1, e2, rax ty))
587 :     | divide (ty, signed, overflow, e1, e2) =
588 :     divrem (ty, signed, overflow, e1, e2, rax ty)
589 :    
590 :     (* rem never causes overflow *)
591 :     fun rem (ty, signed, e1, e2 as T.LI n') =
592 :     (case analyze n' of
593 :     (n, SOME (isneg, a, _)) =>
594 :     if signed then
595 :     (* The following logic should work uniformely
596 :     * for both isneg and not isneg. It only uses
597 :     * the absolute value (a) of the divisor.
598 :     * Here is the formula:
599 :     * let p be a power of two and a = abs(p):
600 :     *
601 :     * x % p = x - ((x < 0 ? x + a - 1 : x) & (-a))
602 :     *
603 :     * (That's what GCC seems to do.)
604 :     *)
605 :     let val r1 = getExpr e1
606 :     val o1 = I.Direct (ty,r1)
607 :     val rt = newReg ()
608 :     val tmp = I.Direct (ty,rt)
609 :     val l = Label.anon ()
610 :     in
611 :     move (ty, o1, tmp);
612 :     if setZeroBit e1 then ()
613 :     else emit ((O.cmpOp ty) { lsrc = o1,
614 :     rsrc = I.Immed 0 });
615 :     emit (I.JCC { cond = I.GE,
616 :     opnd = immedLabel l });
617 :     emit (I.BINARY { binOp = O.addOp ty,
618 :     src = I.Immed (a - 1),
619 :     dst = tmp });
620 :     defineLabel l;
621 :     emit (I.BINARY { binOp = O.andOp ty,
622 :     src = I.Immed (~a),
623 :     dst = tmp });
624 :     binary (ty, O.subOp, T.REG (ty, r1), T.REG (ty, rt))
625 :     end
626 :     else
627 :     if isneg then
628 :     (* this is really strange... *)
629 :     divrem (ty, false, false, e1, e2, rdx ty)
630 :     else
631 :     binaryComm (ty, O.andOp, e1,
632 :     T.LI (T.I.fromInt32 (ty, n - 1)))
633 :     | (_, NONE) => divrem (ty, signed, false, e1, e2, rdx ty))
634 :     | rem(ty, signed, e1, e2) =
635 :     divrem(ty, signed, false, e1, e2, rdx ty)
636 :    
637 :    
638 :     (* unsigned integer multiplication *)
639 :     fun uMultiply0 (ty, e1, e2) =
640 :     (* note e2 can never be (I.Direct rdx) *)
641 :     (move(ty, operand ty e1, rax ty);
642 :     mark(I.MULTDIV{multDivOp=O.mul1Op ty,
643 :     src=regOrMem(ty, operand ty e2)},an);
644 :     move(ty, rax ty, dstOpnd)
645 :     )
646 :    
647 :     fun uMultiply (ty, e1, e2 as T.LI n') =
648 :     (case analyze n' of
649 :     (_, SOME (false, _, p)) => shift (ty, O.shlOp, e1, p)
650 :     | _ => uMultiply0 (ty, e1, e2))
651 :     | uMultiply (ty, e1 as T.LI _, e2) = uMultiply (ty, e2, e1)
652 :     | uMultiply (ty, e1, e2) = uMultiply0 (ty, e1, e2)
653 :    
654 :     (* signed integer multiplication:
655 :     * The only forms that are allowed that also sets the
656 :     * OF and CF flags are:
657 :     *
658 :     * (dst) (src1) (src2)
659 :     * imul r32, r32/m32, imm8
660 :     * (dst) (src)
661 :     * imul r32, imm8
662 :     * imul r32, imm32
663 :     * imul r32, r32/m32
664 :     * Note: destination must be a register!
665 :     *)
666 :     fun multiply (ty, e1, e2) =
667 :     dstMustBeReg(fn (dst, dstOpnd) =>
668 :     let fun doit(i1 as I.Immed _, i2 as I.Immed _) =
669 :     (move(ty, i1, dstOpnd);
670 :     mark(I.BINARY{binOp=O.imulOp ty, dst=dstOpnd, src=i2},an))
671 :     | doit(rm, i2 as I.Immed _) = doit(i2, rm)
672 :     | doit(imm as I.Immed(i), rm) =
673 :     (case ty
674 :     of 32 => mark(I.MUL3{dst=dst, src1=rm, src2=i},an)
675 :     | 64 => mark(I.MULQ3{dst=dst, src1=rm, src2=i},an)
676 :     (* esac *))
677 :     | doit(r1 as I.Direct _, r2 as I.Direct _) =
678 :     (move(ty, r1, dstOpnd);
679 :     mark(I.BINARY{binOp=O.imulOp ty, dst=dstOpnd, src=r2},an))
680 :     | doit(r1 as I.Direct _, rm) =
681 :     (move(ty, r1, dstOpnd);
682 :     mark(I.BINARY{binOp=O.imulOp ty, dst=dstOpnd, src=rm},an))
683 :     | doit(rm, r as I.Direct _) = doit(r, rm)
684 :     | doit(rm1, rm2) =
685 :     if equalDst rm2 then
686 :     let val tmpR = newReg()
687 :     val tmp = I.Direct (ty,tmpR)
688 :     in move(ty, rm1, tmp);
689 :     mark(I.BINARY{binOp=O.imulOp ty, dst=tmp, src=rm2},an);
690 :     move(ty, tmp, dstOpnd)
691 :     end
692 :     else
693 :     (move(ty, rm1, dstOpnd);
694 :     mark(I.BINARY{binOp=O.imulOp ty, dst=dstOpnd, src=rm2},an)
695 :     )
696 :     val (opnd1, opnd2) = (operand ty e1, operand ty e2)
697 :     in doit(opnd1, opnd2)
698 :     end
699 :     )
700 :    
701 :     fun multiply_notrap (ty, e1, e2 as T.LI n') =
702 :     (case analyze n' of
703 :     (_, SOME (isneg, _, p)) => let
704 :     val r1 = getExpr e1
705 :     val o1 = I.Direct (ty,r1)
706 :     in
707 :     if isneg then
708 :     emit (I.UNARY { unOp = O.negOp ty, opnd = o1 })
709 :     else ();
710 :     shift (ty, O.shlOp, T.REG (ty, r1), p)
711 :     end
712 :     | _ => multiply (ty, e1, e2))
713 :     | multiply_notrap (ty, e1 as T.LI _, e2) = multiply_notrap (ty, e2, e1)
714 :     | multiply_notrap (ty, e1, e2) = multiply (ty, e1, e2)
715 :    
716 :    
717 :     in
718 :     (case e
719 :     of T.REG (ty, r) => move' (ty, gpr (ty, r), dstOpnd, an)
720 :     | T.LI z => move' (ty, I.Immed (toInt32 z), dstOpnd, an)
721 :     | (T.CONST _ | T.LABEL _) =>
722 :     move' (ty, I.ImmedLabel e, dstOpnd, an)
723 :     | T.LABEXP le => move' (ty, I.ImmedLabel le, dstOpnd, an)
724 :     (* arithmetic operations *)
725 :     | T.ADD(ty, e1, e2 as T.LI n) => let
726 :     val n = toInt32 n
727 :     in
728 :     case n
729 :     of 1 => unary(ty, O.incOp, e1)
730 :     | ~1 => unary(ty, O.decOp, e1)
731 :     | _ => addition (ty, e1, e2)
732 :     end
733 :     | T.ADD(ty, e1 as T.LI n, e2) => let
734 :     val n = toInt32 n
735 :     in
736 :     case n
737 :     of 1 => unary(ty, O.incOp, e2)
738 :     | ~1 => unary(ty, O.decOp, e2)
739 :     | _ => addition (ty, e1, e2)
740 :     end
741 :     | T.ADD(ty, e1, e2) => addition (ty, e1, e2)
742 :     | T.SUB(ty, e1, e2 as T.LI n) => let
743 :     val n = toInt32 n
744 :     in
745 :     case n
746 :     of 0 => expr' (ty, e1, dst, an)
747 :     | 1 => unary(ty, O.decOp, e1)
748 :     | ~1 => unary(ty, O.incOp, e1)
749 :     | _ => binary(ty, O.subOp, e1, e2)
750 :     end
751 :     | T.SUB(ty, e1 as T.LI n, e2) =>
752 :     if n = 0 then unary(ty, O.negOp, e2)
753 :     else binary(ty, O.subOp, e1, e2)
754 :     | T.SUB(ty, e1, e2) => binary(ty, O.subOp, e1, e2)
755 :     (* unsigned *)
756 :     | T.MULU(ty, x, y) => uMultiply(ty, x, y)
757 :     | T.DIVU(ty, x, y) => divide(ty, false, false, x, y)
758 :     | T.REMU(ty, x, y) => rem(ty, false, x, y)
759 :     (* signed *)
760 :     | T.MULS(ty, x, y) => multiply_notrap (ty, x, y)
761 :     | T.DIVS(T.DIV_TO_ZERO, ty, x, y) =>
762 :     divide(ty, true, false, x, y)
763 :     | T.DIVS(T.DIV_TO_NEGINF, ty, x, y) => divinf (ty, false, x, y)
764 :     | T.REMS(T.DIV_TO_ZERO, ty, x, y) => rem(ty, true, x, y)
765 :     | T.REMS(T.DIV_TO_NEGINF, ty, x, y) => reminf (ty, x, y)
766 :     (* trapping *)
767 :     | T.ADDT(ty, x, y) => (binaryComm(ty, O.addOp, x, y); trap())
768 :     | T.SUBT(ty, x, y) => (binary(ty, O.subOp, x, y); trap())
769 :     | T.MULT(ty, x, y) => (multiply (ty, x, y); trap ())
770 :     | T.DIVT(T.DIV_TO_ZERO, ty, x, y) =>
771 :     divide(ty, true, true, x, y)
772 :     | T.DIVT(T.DIV_TO_NEGINF, ty, x, y) => divinf (ty, true, x, y)
773 :     (* bitwise operations *)
774 :     | T.ANDB(ty, x, y) => binaryComm(ty, O.andOp, x, y)
775 :     | T.ORB(ty, x, y) => binaryComm(ty, O.orOp, x, y)
776 :     | T.XORB(ty, x, y) => binaryComm(ty, O.xorOp, x, y)
777 :     | T.NOTB(ty, x) => unary(ty, O.notOp, x)
778 :     | T.SRA(ty, x, y) => shift(ty, O.sarOp, x, y)
779 :     | T.SRL(ty, x, y) => shift(ty, O.shrOp, x, y)
780 :     | T.SLL(ty, x, y) => shift(ty, O.shlOp, x, y)
781 :     (* loads *)
782 :     | T.LOAD (8, ea, mem) => genLoad (O.loadZXOp (8, 64), ea, mem)
783 :     | T.LOAD (16, ea, mem) => genLoad (O.loadZXOp (16, 64), ea, mem)
784 :     | T.LOAD (32, ea, mem) => genLoad (I.MOVL, ea, mem)
785 :     | T.LOAD (64, ea, mem) => genLoad (I.MOVQ, ea, mem)
786 :     (* sign-extended loads *)
787 :     | T.SX (fTy, tTy, T.LOAD (_, ea, mem)) =>
788 :     genLoad (O.loadSXOp (fTy, tTy), ea, mem)
789 :     (* zero-extended loads *)
790 :     | T.ZX(fTy, tTy, T.LOAD (_, ea, mem)) =>
791 :     genLoad (O.loadZXOp (fTy, tTy), ea, mem)
792 :     | T.LET (s, e) => (stmt s; expr (e, dst, an))
793 :     | _ => raise Fail "todo"
794 :     (* end case *))
795 :     end (* expr' *)
796 :    
797 :     and expr (e, dst, an) = expr' (TRS.size e, e, dst, an)
798 :    
799 :     and fcopy (fty, ds, rs, an) = let
800 :     fun mvInstr {dst, src} =
801 :     [I.fmove {fmvOp=O.fmovOp fty, dst=dst, src=src}]
802 :     val stms = Shuffle.shuffle {mvInstr=mvInstr, ea=fpr}
803 :     {dst=ds, src=rs, tmp=NONE}
804 :     in
805 :     emits stms
806 :     end
807 :    
808 :     (* put a floating-point expression into a register *)
809 : mrainey 2631 and fexpToReg (fty, e) = (case e
810 : mrainey 2619 of T.FREG (fty', r) => r
811 : mrainey 2631 | e => let
812 : mrainey 2619 val r = newFreg ()
813 :     in
814 :     fexpr (fty, r, e, []);
815 :     r
816 :     end
817 : mrainey 2631 (* end case *))
818 : mrainey 2619
819 :     (* put a floating-point expression into an operand *)
820 :     and foperand (fty, e) = (case e
821 :     of T.FLOAD (fty, ea, mem) => address (ea, mem)
822 : mrainey 2631 | T.FREG (fty, r) => I.FDirect r
823 : mrainey 2619 | e => I.FDirect (fexpToReg (fty, e))
824 :     (* end case *))
825 :    
826 :     and fbinop (fty, binOp, a, b, d, an) = let
827 :     val bReg = fexpToReg (fty, b)
828 :     in
829 : mrainey 2631 fexpr (fty, d, a, []);
830 :     mark (I.FBINOP {binOp=binOp, dst=d, src=bReg}, an)
831 : mrainey 2619 end
832 :    
833 :     and convertf2f (fromTy, toTy, e, d, an) = let
834 :     val fmvOp = (case (fromTy, toTy)
835 :     of (32, 64) => I.CVTSS2SD
836 :     | (64, 32) => I.CVTSD2SS
837 :     | _ => error "convertf2f"
838 :     (* end case *))
839 :     in
840 :     mark (I.FMOVE {fmvOp=fmvOp, dst=I.FDirect d,
841 :     src=foperand (fromTy, e)}, an)
842 :     end (* convertf2f *)
843 :    
844 :     and converti2f (fty, ty, e, d, an) = let
845 :     val fmvOp = (case (ty, fty)
846 :     of (32, 32) => I.CVTSI2SS
847 :     | (32, 64) => I.CVTSI2SD
848 :     | (64, 32) => I.CVTSI2SSQ
849 :     | (64, 64) => I.CVTSI2SDQ
850 :     (* end case *))
851 :     in
852 :     mark (I.FMOVE {fmvOp=fmvOp, dst=I.FDirect d,
853 :     src=operand ty e}, an)
854 :     end (* converti2f *)
855 :    
856 :     and fexpr (fty, d, e, an) = ( floatingPointUsed := true;
857 :     case e
858 :     of T.FREG (_, r) => if CB.sameColor (r, d)
859 :     then ()
860 :     else fcopy (fty, [d], [r], an)
861 :     (* binary operators *)
862 :     | T.FADD (_, a, b) => fbinop (fty, O.faddOp fty, a, b, d, an)
863 :     | T.FSUB (_, a, b) => fbinop (fty, O.fsubOp fty, a, b, d, an)
864 :     | T.FMUL (_, a, b) => fbinop (fty, O.fmulOp fty, a, b, d, an)
865 :     | T.FDIV (_, a, b) => fbinop (fty, O.fdivOp fty, a, b, d, an)
866 :     (* unary operators *)
867 :     | T.FNEG (_, a) => raise Fail "todo"
868 :     | T.FABS (_, a) => raise Fail "todo"
869 :     | T.FSQRT (_, a) => raise Fail "todo"
870 :     (* conversions *)
871 :     | T.CVTF2F (fTy, tTy, e) => convertf2f (fTy, tTy, e, d, an)
872 :     | T.CVTI2F (fty, ty, e) => converti2f (fty, ty, e, d, an)
873 :     (* load *)
874 :     | T.FLOAD (fty, ea, mem) => fload (fty, ea, mem, d, an)
875 :     (* misc *)
876 :     | T.FMARK (e, A.MARKREG f) => (f d; fexpr (fty, d, e, an))
877 :     | T.FMARK (e, a) => fexpr (fty, d, e, a::an)
878 :     | T.FPRED (e, c) => fexpr (fty, d, e, A.CTRLUSE c::an)
879 :     | T.FEXT fexp => raise Fail "todo"
880 :     | _ => error "fexpr"
881 :     (* end case *))
882 :    
883 :     and fload (fty, ea, mem, d, an) = mark (
884 :     I.FMOVE {fmvOp=O.fmovOp fty, dst=I.FDirect d,
885 :     src=address (ea, mem)}, an)
886 :    
887 :     and fstore (fty, ea, mem, e, an) = mark (
888 :     I.FMOVE {fmvOp=O.fmovOp fty, dst=address (ea, mem),
889 :     src=I.FDirect (fexpToReg (fty, e))}, an)
890 :    
891 :     and call (ea, flow, def, use, mem, cutsTo, an, pops) = let
892 :     fun return(set, []) = set
893 :     | return(set, a::an) = (case #peek A.RETURN_ARG a
894 :     of SOME r => return(CB.CellSet.add(r, set), an)
895 :     | NONE => return(set, an)
896 :     (* end case *))
897 :     in
898 :     mark(I.CALL{opnd=operand 32 ea,defs=cellset def,uses=cellset use,
899 :     return=return (C.empty,an),cutsTo=cutsTo,mem=mem,
900 :     pops=pops},an)
901 :     end (* call *)
902 :    
903 :     and jmp (lexp as T.LABEL lab, labs, an) =
904 :     mark (I.JMP (I.ImmedLabel lexp, [lab]), an)
905 :     | jmp (T.LABEXP le, labs, an) = mark (I.JMP (I.ImmedLabel le, labs), an)
906 :     | jmp (ea, labs, an) = mark (I.JMP (operand 64 ea, labs), an)
907 :    
908 :     and doStore ty (ea, d, mem, an) =
909 :     move' (ty, immedOrReg (ty, operand ty d), address (ea, mem), an)
910 :    
911 :     and binaryMem(ty, binOp, src, dst, mem, an) =
912 :     mark(I.BINARY{binOp=binOp, src=immedOrReg(ty, operand ty src),
913 :     dst=address (dst,mem)}, an)
914 :     and unaryMem(ty, unOp, opnd, mem, an) =
915 :     mark(I.UNARY{unOp=unOp, opnd=address (opnd,mem)}, an)
916 :     and isOne(T.LI n) = n = 1
917 :     | isOne _ = false
918 :    
919 :     and store (ty, ea, d, mem,
920 :     {INC,DEC,ADD,SUB,NOT,NEG,SHL,SHR,SAR,OR,AND,XOR, ...} : O.opcodes,
921 :     doStore, an) = let
922 :     fun default () = doStore (ea, d, mem, an)
923 :     fun binary1 (t, t', unary, binary, ea', x) =
924 :     if t = ty andalso t' = ty then
925 :     if MLTreeUtils.eqRexp(ea, ea') then
926 :     if isOne x then unaryMem(ty, unary, ea, mem, an)
927 :     else binaryMem(ty, binary, x, ea, mem, an)
928 :     else default()
929 :     else default()
930 :     fun unary(t,unOp, ea') =
931 :     if t = ty andalso MLTreeUtils.eqRexp(ea, ea') then
932 :     unaryMem(ty, unOp, ea, mem, an)
933 :     else default()
934 :     fun binary(t,t',binOp,ea',x) =
935 :     if t = ty andalso t' = ty andalso
936 :     MLTreeUtils.eqRexp(ea, ea') then
937 :     binaryMem(ty, binOp, x, ea, mem, an)
938 :     else default()
939 :     fun binaryCom1(t,unOp,binOp,x,y) =
940 :     if t = ty then let
941 :     fun again() = (case y
942 :     of T.LOAD(ty',ea',_) =>
943 :     if ty' = ty andalso MLTreeUtils.eqRexp(ea, ea') then
944 :     if isOne x then unaryMem(ty, unOp, ea, mem, an)
945 :     else binaryMem(ty, binOp,x,ea,mem,an)
946 :     else default()
947 :     | _ => default()
948 :     (* end case *))
949 :     in
950 :     (case x
951 :     of T.LOAD(ty',ea',_) => if ty' = ty
952 :     andalso MLTreeUtils.eqRexp(ea, ea') then
953 :     if isOne y then unaryMem(ty, unOp, ea, mem, an)
954 :     else binaryMem(ty, binOp,y,ea,mem,an)
955 :     else again()
956 :     | _ => again()
957 :     (* end case *))
958 :     end
959 :     else default()
960 :     fun binaryCom(t,binOp,x,y) = if t = ty then
961 :     let fun again() = (case y
962 :     of T.LOAD(ty',ea',_) =>
963 :     if ty' = ty andalso MLTreeUtils.eqRexp(ea, ea') then
964 :     binaryMem(ty, binOp,x,ea,mem,an)
965 :     else default()
966 :     | _ => default()
967 :     (* end case *))
968 :     in
969 :     (case x
970 :     of T.LOAD(ty',ea',_) =>
971 :     if ty' = ty andalso MLTreeUtils.eqRexp(ea, ea') then
972 :     binaryMem(ty, binOp,y,ea,mem,an)
973 :     else again()
974 :     | _ => again()
975 :     (* end case *))
976 :     end
977 :     else default()
978 :     in
979 :     (case d
980 :     of T.ADD(t,x,y) => binaryCom1(t,INC,ADD,x,y)
981 :     | T.SUB(t,T.LOAD(t',ea',_),x) => binary1(t,t',DEC,SUB,ea',x)
982 :     | T.ORB(t,x,y) => binaryCom(t,OR,x,y)
983 :     | T.ANDB(t,x,y) => binaryCom(t,AND,x,y)
984 :     | T.XORB(t,x,y) => binaryCom(t,XOR,x,y)
985 :     | T.SLL(t,T.LOAD(t',ea',_),x) => binary(t,t',SHL,ea',x)
986 :     | T.SRL(t,T.LOAD(t',ea',_),x) => binary(t,t',SHR,ea',x)
987 :     | T.SRA(t,T.LOAD(t',ea',_),x) => binary(t,t',SAR,ea',x)
988 :     | T.NEG(t,T.LOAD(t',ea',_)) => unary(t,NEG,ea')
989 :     | T.NOTB (t, T.LOAD(t',ea',_)) => unary(t,NOT,ea')
990 :     | _ => default ()
991 :     (* end case *))
992 :     end (* store *)
993 :    
994 :     and reducer () = raise Fail "todo"
995 :    
996 :     and fbranch (fty, fcc, t1, t2, lab, an) = let
997 :     fun j cc = mark (I.JCC {cond=cc, opnd=immedLabel lab}, an)
998 :     in
999 :     fbranch' (fty, fcc, t1, t2, j)
1000 :     end
1001 :    
1002 :     and fbranch' (fty, fcc, t1, t2, j) = let
1003 :     fun branch fcc = (case fcc
1004 :     of T.== => j I.P
1005 :     | T.?<> => j I.NE
1006 :     | T.? => j I.P
1007 :     | T.<=> => j I.NP
1008 :     | T.> => j I.B
1009 :     | T.?<= => j I.BE
1010 :     | T.>= => j I.AE
1011 :     | T.?< => j I.BE
1012 :     | T.< => j I.A
1013 :     | T.?>= => j I.AE
1014 :     | T.<= => j I.BE
1015 :     | T.?> => j I.A
1016 :     | T.<> => j I.NE
1017 :     | T.?= => j I.P
1018 :     | _ => error(concat[
1019 :     "fbranch(", T.Basis.fcondToString fcc, ")"])
1020 :     (*esac*))
1021 :     fun compare () = let
1022 :     val l = foperand (fty, t1)
1023 :     val r = foperand (fty, t2)
1024 :     fun cmp (l, r, fcc) = (
1025 :     emit (I.FCOM {comOp=O.ucomOp fty, src=r, dst=l});
1026 :     fcc)
1027 :     in
1028 :     (case (l, r)
1029 :     of (I.FDirect lReg, I.FDirect _) => cmp (lReg, r, fcc)
1030 :     | (mem, I.FDirect rReg) =>
1031 : mrainey 2631 cmp (rReg, l, T.Basis.swapFcond fcc)
1032 : mrainey 2619 | (I.FDirect lReg, mem) => cmp (lReg, r, fcc)
1033 :     | _ => let
1034 :     val tmpR = newFreg ()
1035 :     val tmp = I.FDirect tmpR
1036 :     in
1037 :     emit (I.FMOVE {fmvOp=O.fmovOp fty, src=l, dst=tmp});
1038 :     cmp (tmpR, r, fcc)
1039 :     end
1040 :     (* esac *))
1041 :     end (* compare *)
1042 :     in
1043 :     branch (compare ())
1044 :     end (* fbranch' *)
1045 :    
1046 :     (* %eflags <- src *)
1047 :     and moveToEflags src =
1048 :     if CB.sameColor(src, C.eflags) then ()
1049 :     else (move(32, I.Direct (32,src), rax 32); emit(I.LAHF))
1050 :    
1051 :     (* dst <- %eflags *)
1052 :     and moveFromEflags dst =
1053 :     if CB.sameColor(dst, C.eflags) then ()
1054 :     else (emit(I.SAHF); move(32, rax 32, I.Direct (32,dst)))
1055 :    
1056 :     (* Emit a test.
1057 :     * The available modes are
1058 :     * r/m, r
1059 :     * r/m, imm
1060 :     * On selecting the right instruction: TESTQ/TESTL/TESTW/TESTB.
1061 :     * When anding an operand with a constant
1062 :     * that fits within 8 (or 16) bits, it is possible to use TESTB,
1063 :     * (or TESTW) instead of TESTL. Because amd64 is little endian,
1064 :     * this works for memory operands too. However, with TESTB, it is
1065 :     * not possible to use registers other than
1066 :     * AL, CL, BL, DL, and AH, CH, BH, DH. So, the best way is to
1067 :     * perform register allocation first, and if the operand registers
1068 :     * are one of RAX, RCX, RBX, or RDX, replace the TESTL instruction
1069 :     * by TESTB.
1070 :     *)
1071 :     and test(ty, testopcode, a, b, an) = let
1072 :     val (_, opnd1, opnd2) = commuteComparison(ty, T.EQ, true, a, b)
1073 :     (* translate r, r/m => r/m, r *)
1074 :     val (opnd1, opnd2) =
1075 :     if isMemOpnd opnd2 then (opnd2, opnd1) else (opnd1, opnd2)
1076 :     in
1077 :     mark (testopcode {lsrc=opnd1, rsrc=opnd2}, an)
1078 :     end
1079 :    
1080 :     (* generate a real comparison; return the real cc used *)
1081 :     and genCmp(ty, swapable, cc, a, b, an) =
1082 :     let val (cc, opnd1, opnd2) = commuteComparison(ty, cc, swapable, a, b)
1083 :     in
1084 :     (case ty
1085 :     of 8 => mark(I.CMPB{lsrc=opnd1, rsrc=opnd2}, an)
1086 :     | 16 => mark(I.CMPW{lsrc=opnd1, rsrc=opnd2}, an)
1087 :     | 32 => mark(I.CMPL{lsrc=opnd1, rsrc=opnd2}, an)
1088 :     | 64 => mark(I.CMPQ{lsrc=opnd1, rsrc=opnd2}, an)
1089 :     (* esac *));
1090 :     cc
1091 :     end
1092 :    
1093 :     (* Give a and b which are the operands to a comparison (or test)
1094 :     * Return the appropriate condition code and operands.
1095 :     * The available modes are:
1096 :     * r/m, imm
1097 :     * r/m, r
1098 :     * r, r/m
1099 :     *)
1100 :     and commuteComparison(ty, cc, swapable, a, b) = let
1101 :     val (opnd1, opnd2) = (operand ty a, operand ty b)
1102 :     in (* Try to fold in the operands whenever possible *)
1103 :     (case (isImmediate opnd1, isImmediate opnd2)
1104 :     of (true, true) => (cc, moveToReg (ty, opnd1), opnd2)
1105 :     | (true, false) =>
1106 :     if swapable then (T.Basis.swapCond cc, opnd2, opnd1)
1107 :     else (cc, moveToReg (ty, opnd1), opnd2)
1108 :     | (false, true) => (cc, opnd1, opnd2)
1109 :     | (false, false) => (case (opnd1, opnd2)
1110 :     of (_, I.Direct _) => (cc, opnd1, opnd2)
1111 :     | (I.Direct _, _) => (cc, opnd1, opnd2)
1112 :     | (_, _) => (cc, moveToReg (ty, opnd1), opnd2)
1113 :     (* end case *))
1114 :     (* end case *))
1115 :     end (* commuteComparison *)
1116 :    
1117 :     (* generate a condition code expression
1118 :     * The zero is for setting the condition code!
1119 :     * I have no idea why this is used.
1120 :     *)
1121 :     and doCCexpr(T.CMP(ty, cc, t1, t2), dst, an) = (
1122 :     cmp(false, ty, cc, t1, t2, an);
1123 :     moveFromEflags dst)
1124 :     | doCCexpr(T.CC(cond,rs), dst, an) =
1125 :     if CB.sameColor(rs,C.eflags) orelse CB.sameColor(dst,C.eflags)
1126 :     then (moveToEflags rs; moveFromEflags dst)
1127 :     else move'(64, I.Direct (64,rs), I.Direct (64,dst), an)
1128 :     | doCCexpr(T.CCMARK(e,A.MARKREG f),dst,an) = (f dst; doCCexpr(e,dst,an))
1129 :     | doCCexpr(T.CCMARK(e,a), dst, an) = doCCexpr(e,dst,a::an)
1130 :     | doCCexpr(T.CCEXT e, cd, an) =
1131 :     ExtensionComp.compileCCext (reducer()) {e=e, ccd=cd, an=an}
1132 :     | doCCexpr _ = error "doCCexpr"
1133 :    
1134 :     (* Compare an expression with zero.
1135 :     * On the amd64, TEST is superior to AND for doing the same thing,
1136 :     * since it doesn't need to write out the result in a register.
1137 :     *)
1138 :     and cmpWithZero(cc as (T.EQ | T.NE), e as T.ANDB(ty, a, b), an) =
1139 :     (case ty
1140 : mrainey 2631 of 8 => test(ty, I.TESTB, a, b, an)
1141 : mrainey 2619 | 16 => test(ty, I.TESTW, a, b, an)
1142 :     | 32 => test(ty, I.TESTL, a, b, an)
1143 :     | 64 => test(ty, I.TESTQ, a, b, an)
1144 :     | _ => expr (e, newReg(), an);
1145 :     cc)
1146 :     | cmpWithZero(cc, e, an) = (expr (e, newReg(), an); cc)
1147 :    
1148 :     (* generate a comparison and sets the condition code;
1149 :     * return the actual cc used. If the flag swapable is true,
1150 :     * we can also reorder the operands.
1151 :     *)
1152 :     and cmp (swapable, ty, cc, t1, t2, an) =
1153 :     (* == and <> can be always be reordered *)
1154 :     let val swapable = swapable orelse cc = T.EQ orelse cc = T.NE
1155 :     in (* Sometimes the comparison is not necessary because
1156 :     * the bits are already set!
1157 :     *)
1158 :     if isZero t1 andalso setZeroBit2 t2 then
1159 :     if swapable then
1160 :     cmpWithZero(T.Basis.swapCond cc, t2, an)
1161 :     else (* can't reorder the comparison! *)
1162 :     genCmp(ty, false, cc, t1, t2, an)
1163 :     else if isZero t2 andalso setZeroBit2 t1 then
1164 :     cmpWithZero(cc, t1, an)
1165 :     else genCmp(ty, swapable, cc, t1, t2, an)
1166 :     end
1167 :    
1168 :     and branch (T.CMP(ty, cc, t1, t2), lab, an) = let
1169 :     val cc = cmp (true, ty, cc, t1, t2, [])
1170 :     in
1171 :     mark (I.JCC{cond=cond cc, opnd=immedLabel lab}, an)
1172 :     end
1173 :     | branch (T.FCMP(fty, fcc, t1, t2), lab, an) =
1174 :     fbranch (fty, fcc, t1, t2, lab, an)
1175 :     | branch (ccexp, lab, an) = (
1176 :     doCCexpr(ccexp, C.eflags, []);
1177 :     mark(I.JCC{cond=cond(Gen.condOf ccexp), opnd=immedLabel lab}, an))
1178 :    
1179 :     and stmt' (s, an) = (case s
1180 :     of T.MV (ty, d, e) => expr' (ty, e, d, an)
1181 :     | T.FMV (fty, d, e) => fexpr (fty, d, e, an)
1182 :     | T.CCMV (ccd, e) => raise Fail "todo"
1183 :     | T.COPY (ty, dst, src) => copy (ty, dst, src, an)
1184 :     | T.FCOPY (fty, dst, src) => fcopy (fty, dst, src, an)
1185 :     | T.JMP (e, labs) => jmp (e, labs, an)
1186 :     | T.CALL {funct, targets, defs, uses, region, pops, ...} =>
1187 :     call (funct, targets, defs, uses, region, [], an, pops)
1188 :     | T.FLOW_TO(T.CALL{funct, targets, defs, uses, region, pops, ...},
1189 :     cutTo) =>
1190 :     call (funct, targets, defs, uses, region, cutTo, an, pops)
1191 :     | T.RET _ => mark (I.RET NONE, an)
1192 :     | T.STORE (ty, ea, d, mem) =>
1193 :     store (ty, ea, d, mem, O.opcodes ty, doStore ty, an)
1194 :     | T.FSTORE (fty, ea, e, mem) => fstore (fty, ea, mem, e, an)
1195 :     | T.BCC(cc, lab) => branch (cc, lab, an)
1196 :     | T.DEFINE l => defineLabel l
1197 :     | T.LIVE s => mark' (I.LIVE{regs=cellset s,spilled=C.empty},an)
1198 :     | T.KILL s => mark' (I.KILL{regs=cellset s,spilled=C.empty},an)
1199 :     | T.ANNOTATION(s, a) => stmt' (s, a::an)
1200 :     | T.EXT s =>
1201 :     ExtensionComp.compileSext (reducer ()) {stm=s, an=an}
1202 :     | s => app stmt (Gen.compileStm s)
1203 :     (* end case *))
1204 :     and stmt s = stmt' (s, [])
1205 :    
1206 :     fun beginCluster' _ = (
1207 :     trapLabel := NONE;
1208 :     beginCluster 0)
1209 :     fun endCluster' a = (
1210 :     (case !trapLabel
1211 :     of NONE => ()
1212 :     | SOME(_, lab) => (defineLabel lab; emit I.INTO)
1213 :     (* end case *));
1214 :     (* If floating point has been used allocate an extra
1215 :     * register just in case we didn't use any explicit register *)
1216 :     if !floatingPointUsed then ignore (newFreg ()) else ();
1217 :     endCluster a)
1218 :    
1219 :     fun self () = TS.S.STREAM {
1220 :     beginCluster=beginCluster',
1221 :     endCluster=endCluster',
1222 :     emit=stmt,
1223 :     pseudoOp=pseudoOp,
1224 :     defineLabel=defineLabel,
1225 :     entryLabel=entryLabel,
1226 :     comment=comment,
1227 :     annotation=annotation,
1228 :     getAnnotations=getAnnotations,
1229 :     exitBlock=exitBlock o cellset}
1230 :     in
1231 :     self ()
1232 :     end (* selectInstructions *)
1233 :    
1234 :     end (* AMD64Gen *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0