Support MO_WriteBarrier in PowerPC NCG (lwsync instruction)
[ghc.git] / compiler / nativeGen / PprMach.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Pretty-printing assembly language
4 --
5 -- (c) The University of Glasgow 1993-2005
6 --
7 -----------------------------------------------------------------------------
8
9 -- We start with the @pprXXX@s with some cross-platform commonality
10 -- (e.g., 'pprReg'); we conclude with the no-commonality monster,
11 -- 'pprInstr'.
12
13 #include "nativeGen/NCG.h"
14
15 module PprMach (
16 pprNatCmmTop, pprBasicBlock,
17 pprInstr, pprSize, pprUserReg,
18 ) where
19
20
21 #include "HsVersions.h"
22
23 import Cmm
24 import MachOp ( MachRep(..), wordRep, isFloatingRep )
25 import MachRegs -- may differ per-platform
26 import MachInstrs
27
28 import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel,
29 labelDynamic, mkAsmTempLabel, entryLblToInfoLbl )
30 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
31 import CLabel ( mkDeadStripPreventer )
32 #endif
33
34 import Panic ( panic )
35 import Unique ( pprUnique )
36 import Pretty
37 import FastString
38 import qualified Outputable
39
40 import Data.Array.ST
41 import Data.Word ( Word8 )
42 import Control.Monad.ST
43 import Data.Char ( chr, ord )
44 import Data.Maybe ( isJust )
45
46 #if powerpc_TARGET_ARCH || darwin_TARGET_OS
47 import Data.Word(Word32)
48 import Data.Bits
49 #endif
50
51 -- -----------------------------------------------------------------------------
52 -- Printing this stuff out
53
54 asmSDoc d = Outputable.withPprStyleDoc (
55 Outputable.mkCodeStyle Outputable.AsmStyle) d
56 pprCLabel_asm l = asmSDoc (pprCLabel l)
57
58 pprNatCmmTop :: NatCmmTop -> Doc
59 pprNatCmmTop (CmmData section dats) =
60 pprSectionHeader section $$ vcat (map pprData dats)
61
62 -- special case for split markers:
63 pprNatCmmTop (CmmProc [] lbl _ []) = pprLabel lbl
64
65 pprNatCmmTop (CmmProc info lbl params blocks) =
66 pprSectionHeader Text $$
67 (if not (null info)
68 then
69 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
70 pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
71 <> char ':' $$
72 #endif
73 vcat (map pprData info) $$
74 pprLabel (entryLblToInfoLbl lbl)
75 else empty) $$
76 (case blocks of
77 [] -> empty
78 (BasicBlock _ instrs : rest) ->
79 (if null info then pprLabel lbl else empty) $$
80 -- the first block doesn't get a label:
81 vcat (map pprInstr instrs) $$
82 vcat (map pprBasicBlock rest)
83 )
84 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
85 -- If we are using the .subsections_via_symbols directive
86 -- (available on recent versions of Darwin),
87 -- we have to make sure that there is some kind of reference
88 -- from the entry code to a label on the _top_ of of the info table,
89 -- so that the linker will not think it is unreferenced and dead-strip
90 -- it. That's why the label is called a DeadStripPreventer (_dsp).
91 $$ if not (null info)
92 then text "\t.long "
93 <+> pprCLabel_asm (entryLblToInfoLbl lbl)
94 <+> char '-'
95 <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
96 else empty
97 #endif
98
99
100 pprBasicBlock :: NatBasicBlock -> Doc
101 pprBasicBlock (BasicBlock (BlockId id) instrs) =
102 pprLabel (mkAsmTempLabel id) $$
103 vcat (map pprInstr instrs)
104
105 -- -----------------------------------------------------------------------------
106 -- pprReg: print a 'Reg'
107
108 -- For x86, the way we print a register name depends
109 -- on which bit of it we care about. Yurgh.
110
111 pprUserReg :: Reg -> Doc
112 pprUserReg = pprReg IF_ARCH_i386(I32,) IF_ARCH_x86_64(I64,)
113
114 pprReg :: IF_ARCH_i386(MachRep ->,) IF_ARCH_x86_64(MachRep ->,) Reg -> Doc
115
116 pprReg IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) r
117 = case r of
118 RealReg i -> ppr_reg_no IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) i
119 VirtualRegI u -> text "%vI_" <> asmSDoc (pprUnique u)
120 VirtualRegHi u -> text "%vHi_" <> asmSDoc (pprUnique u)
121 VirtualRegF u -> text "%vF_" <> asmSDoc (pprUnique u)
122 VirtualRegD u -> text "%vD_" <> asmSDoc (pprUnique u)
123 where
124 #if alpha_TARGET_ARCH
125 ppr_reg_no :: Int -> Doc
126 ppr_reg_no i = ptext
127 (case i of {
128 0 -> SLIT("$0"); 1 -> SLIT("$1");
129 2 -> SLIT("$2"); 3 -> SLIT("$3");
130 4 -> SLIT("$4"); 5 -> SLIT("$5");
131 6 -> SLIT("$6"); 7 -> SLIT("$7");
132 8 -> SLIT("$8"); 9 -> SLIT("$9");
133 10 -> SLIT("$10"); 11 -> SLIT("$11");
134 12 -> SLIT("$12"); 13 -> SLIT("$13");
135 14 -> SLIT("$14"); 15 -> SLIT("$15");
136 16 -> SLIT("$16"); 17 -> SLIT("$17");
137 18 -> SLIT("$18"); 19 -> SLIT("$19");
138 20 -> SLIT("$20"); 21 -> SLIT("$21");
139 22 -> SLIT("$22"); 23 -> SLIT("$23");
140 24 -> SLIT("$24"); 25 -> SLIT("$25");
141 26 -> SLIT("$26"); 27 -> SLIT("$27");
142 28 -> SLIT("$28"); 29 -> SLIT("$29");
143 30 -> SLIT("$30"); 31 -> SLIT("$31");
144 32 -> SLIT("$f0"); 33 -> SLIT("$f1");
145 34 -> SLIT("$f2"); 35 -> SLIT("$f3");
146 36 -> SLIT("$f4"); 37 -> SLIT("$f5");
147 38 -> SLIT("$f6"); 39 -> SLIT("$f7");
148 40 -> SLIT("$f8"); 41 -> SLIT("$f9");
149 42 -> SLIT("$f10"); 43 -> SLIT("$f11");
150 44 -> SLIT("$f12"); 45 -> SLIT("$f13");
151 46 -> SLIT("$f14"); 47 -> SLIT("$f15");
152 48 -> SLIT("$f16"); 49 -> SLIT("$f17");
153 50 -> SLIT("$f18"); 51 -> SLIT("$f19");
154 52 -> SLIT("$f20"); 53 -> SLIT("$f21");
155 54 -> SLIT("$f22"); 55 -> SLIT("$f23");
156 56 -> SLIT("$f24"); 57 -> SLIT("$f25");
157 58 -> SLIT("$f26"); 59 -> SLIT("$f27");
158 60 -> SLIT("$f28"); 61 -> SLIT("$f29");
159 62 -> SLIT("$f30"); 63 -> SLIT("$f31");
160 _ -> SLIT("very naughty alpha register")
161 })
162 #endif
163 #if i386_TARGET_ARCH
164 ppr_reg_no :: MachRep -> Int -> Doc
165 ppr_reg_no I8 = ppr_reg_byte
166 ppr_reg_no I16 = ppr_reg_word
167 ppr_reg_no _ = ppr_reg_long
168
169 ppr_reg_byte i = ptext
170 (case i of {
171 0 -> SLIT("%al"); 1 -> SLIT("%bl");
172 2 -> SLIT("%cl"); 3 -> SLIT("%dl");
173 _ -> SLIT("very naughty I386 byte register")
174 })
175
176 ppr_reg_word i = ptext
177 (case i of {
178 0 -> SLIT("%ax"); 1 -> SLIT("%bx");
179 2 -> SLIT("%cx"); 3 -> SLIT("%dx");
180 4 -> SLIT("%si"); 5 -> SLIT("%di");
181 6 -> SLIT("%bp"); 7 -> SLIT("%sp");
182 _ -> SLIT("very naughty I386 word register")
183 })
184
185 ppr_reg_long i = ptext
186 (case i of {
187 0 -> SLIT("%eax"); 1 -> SLIT("%ebx");
188 2 -> SLIT("%ecx"); 3 -> SLIT("%edx");
189 4 -> SLIT("%esi"); 5 -> SLIT("%edi");
190 6 -> SLIT("%ebp"); 7 -> SLIT("%esp");
191 8 -> SLIT("%fake0"); 9 -> SLIT("%fake1");
192 10 -> SLIT("%fake2"); 11 -> SLIT("%fake3");
193 12 -> SLIT("%fake4"); 13 -> SLIT("%fake5");
194 _ -> SLIT("very naughty I386 register")
195 })
196 #endif
197
198 #if x86_64_TARGET_ARCH
199 ppr_reg_no :: MachRep -> Int -> Doc
200 ppr_reg_no I8 = ppr_reg_byte
201 ppr_reg_no I16 = ppr_reg_word
202 ppr_reg_no I32 = ppr_reg_long
203 ppr_reg_no _ = ppr_reg_quad
204
205 ppr_reg_byte i = ptext
206 (case i of {
207 0 -> SLIT("%al"); 1 -> SLIT("%bl");
208 2 -> SLIT("%cl"); 3 -> SLIT("%dl");
209 4 -> SLIT("%sil"); 5 -> SLIT("%dil"); -- new 8-bit regs!
210 6 -> SLIT("%bpl"); 7 -> SLIT("%spl");
211 8 -> SLIT("%r8b"); 9 -> SLIT("%r9b");
212 10 -> SLIT("%r10b"); 11 -> SLIT("%r11b");
213 12 -> SLIT("%r12b"); 13 -> SLIT("%r13b");
214 14 -> SLIT("%r14b"); 15 -> SLIT("%r15b");
215 _ -> SLIT("very naughty x86_64 byte register")
216 })
217
218 ppr_reg_word i = ptext
219 (case i of {
220 0 -> SLIT("%ax"); 1 -> SLIT("%bx");
221 2 -> SLIT("%cx"); 3 -> SLIT("%dx");
222 4 -> SLIT("%si"); 5 -> SLIT("%di");
223 6 -> SLIT("%bp"); 7 -> SLIT("%sp");
224 8 -> SLIT("%r8w"); 9 -> SLIT("%r9w");
225 10 -> SLIT("%r10w"); 11 -> SLIT("%r11w");
226 12 -> SLIT("%r12w"); 13 -> SLIT("%r13w");
227 14 -> SLIT("%r14w"); 15 -> SLIT("%r15w");
228 _ -> SLIT("very naughty x86_64 word register")
229 })
230
231 ppr_reg_long i = ptext
232 (case i of {
233 0 -> SLIT("%eax"); 1 -> SLIT("%ebx");
234 2 -> SLIT("%ecx"); 3 -> SLIT("%edx");
235 4 -> SLIT("%esi"); 5 -> SLIT("%edi");
236 6 -> SLIT("%ebp"); 7 -> SLIT("%esp");
237 8 -> SLIT("%r8d"); 9 -> SLIT("%r9d");
238 10 -> SLIT("%r10d"); 11 -> SLIT("%r11d");
239 12 -> SLIT("%r12d"); 13 -> SLIT("%r13d");
240 14 -> SLIT("%r14d"); 15 -> SLIT("%r15d");
241 _ -> SLIT("very naughty x86_64 register")
242 })
243
244 ppr_reg_quad i = ptext
245 (case i of {
246 0 -> SLIT("%rax"); 1 -> SLIT("%rbx");
247 2 -> SLIT("%rcx"); 3 -> SLIT("%rdx");
248 4 -> SLIT("%rsi"); 5 -> SLIT("%rdi");
249 6 -> SLIT("%rbp"); 7 -> SLIT("%rsp");
250 8 -> SLIT("%r8"); 9 -> SLIT("%r9");
251 10 -> SLIT("%r10"); 11 -> SLIT("%r11");
252 12 -> SLIT("%r12"); 13 -> SLIT("%r13");
253 14 -> SLIT("%r14"); 15 -> SLIT("%r15");
254 16 -> SLIT("%xmm0"); 17 -> SLIT("%xmm1");
255 18 -> SLIT("%xmm2"); 19 -> SLIT("%xmm3");
256 20 -> SLIT("%xmm4"); 21 -> SLIT("%xmm5");
257 22 -> SLIT("%xmm6"); 23 -> SLIT("%xmm7");
258 24 -> SLIT("%xmm8"); 25 -> SLIT("%xmm9");
259 26 -> SLIT("%xmm10"); 27 -> SLIT("%xmm11");
260 28 -> SLIT("%xmm12"); 29 -> SLIT("%xmm13");
261 30 -> SLIT("%xmm14"); 31 -> SLIT("%xmm15");
262 _ -> SLIT("very naughty x86_64 register")
263 })
264 #endif
265
266 #if sparc_TARGET_ARCH
267 ppr_reg_no :: Int -> Doc
268 ppr_reg_no i = ptext
269 (case i of {
270 0 -> SLIT("%g0"); 1 -> SLIT("%g1");
271 2 -> SLIT("%g2"); 3 -> SLIT("%g3");
272 4 -> SLIT("%g4"); 5 -> SLIT("%g5");
273 6 -> SLIT("%g6"); 7 -> SLIT("%g7");
274 8 -> SLIT("%o0"); 9 -> SLIT("%o1");
275 10 -> SLIT("%o2"); 11 -> SLIT("%o3");
276 12 -> SLIT("%o4"); 13 -> SLIT("%o5");
277 14 -> SLIT("%o6"); 15 -> SLIT("%o7");
278 16 -> SLIT("%l0"); 17 -> SLIT("%l1");
279 18 -> SLIT("%l2"); 19 -> SLIT("%l3");
280 20 -> SLIT("%l4"); 21 -> SLIT("%l5");
281 22 -> SLIT("%l6"); 23 -> SLIT("%l7");
282 24 -> SLIT("%i0"); 25 -> SLIT("%i1");
283 26 -> SLIT("%i2"); 27 -> SLIT("%i3");
284 28 -> SLIT("%i4"); 29 -> SLIT("%i5");
285 30 -> SLIT("%i6"); 31 -> SLIT("%i7");
286 32 -> SLIT("%f0"); 33 -> SLIT("%f1");
287 34 -> SLIT("%f2"); 35 -> SLIT("%f3");
288 36 -> SLIT("%f4"); 37 -> SLIT("%f5");
289 38 -> SLIT("%f6"); 39 -> SLIT("%f7");
290 40 -> SLIT("%f8"); 41 -> SLIT("%f9");
291 42 -> SLIT("%f10"); 43 -> SLIT("%f11");
292 44 -> SLIT("%f12"); 45 -> SLIT("%f13");
293 46 -> SLIT("%f14"); 47 -> SLIT("%f15");
294 48 -> SLIT("%f16"); 49 -> SLIT("%f17");
295 50 -> SLIT("%f18"); 51 -> SLIT("%f19");
296 52 -> SLIT("%f20"); 53 -> SLIT("%f21");
297 54 -> SLIT("%f22"); 55 -> SLIT("%f23");
298 56 -> SLIT("%f24"); 57 -> SLIT("%f25");
299 58 -> SLIT("%f26"); 59 -> SLIT("%f27");
300 60 -> SLIT("%f28"); 61 -> SLIT("%f29");
301 62 -> SLIT("%f30"); 63 -> SLIT("%f31");
302 _ -> SLIT("very naughty sparc register")
303 })
304 #endif
305 #if powerpc_TARGET_ARCH
306 #if darwin_TARGET_OS
307 ppr_reg_no :: Int -> Doc
308 ppr_reg_no i = ptext
309 (case i of {
310 0 -> SLIT("r0"); 1 -> SLIT("r1");
311 2 -> SLIT("r2"); 3 -> SLIT("r3");
312 4 -> SLIT("r4"); 5 -> SLIT("r5");
313 6 -> SLIT("r6"); 7 -> SLIT("r7");
314 8 -> SLIT("r8"); 9 -> SLIT("r9");
315 10 -> SLIT("r10"); 11 -> SLIT("r11");
316 12 -> SLIT("r12"); 13 -> SLIT("r13");
317 14 -> SLIT("r14"); 15 -> SLIT("r15");
318 16 -> SLIT("r16"); 17 -> SLIT("r17");
319 18 -> SLIT("r18"); 19 -> SLIT("r19");
320 20 -> SLIT("r20"); 21 -> SLIT("r21");
321 22 -> SLIT("r22"); 23 -> SLIT("r23");
322 24 -> SLIT("r24"); 25 -> SLIT("r25");
323 26 -> SLIT("r26"); 27 -> SLIT("r27");
324 28 -> SLIT("r28"); 29 -> SLIT("r29");
325 30 -> SLIT("r30"); 31 -> SLIT("r31");
326 32 -> SLIT("f0"); 33 -> SLIT("f1");
327 34 -> SLIT("f2"); 35 -> SLIT("f3");
328 36 -> SLIT("f4"); 37 -> SLIT("f5");
329 38 -> SLIT("f6"); 39 -> SLIT("f7");
330 40 -> SLIT("f8"); 41 -> SLIT("f9");
331 42 -> SLIT("f10"); 43 -> SLIT("f11");
332 44 -> SLIT("f12"); 45 -> SLIT("f13");
333 46 -> SLIT("f14"); 47 -> SLIT("f15");
334 48 -> SLIT("f16"); 49 -> SLIT("f17");
335 50 -> SLIT("f18"); 51 -> SLIT("f19");
336 52 -> SLIT("f20"); 53 -> SLIT("f21");
337 54 -> SLIT("f22"); 55 -> SLIT("f23");
338 56 -> SLIT("f24"); 57 -> SLIT("f25");
339 58 -> SLIT("f26"); 59 -> SLIT("f27");
340 60 -> SLIT("f28"); 61 -> SLIT("f29");
341 62 -> SLIT("f30"); 63 -> SLIT("f31");
342 _ -> SLIT("very naughty powerpc register")
343 })
344 #else
345 ppr_reg_no :: Int -> Doc
346 ppr_reg_no i | i <= 31 = int i -- GPRs
347 | i <= 63 = int (i-32) -- FPRs
348 | otherwise = ptext SLIT("very naughty powerpc register")
349 #endif
350 #endif
351
352
353 -- -----------------------------------------------------------------------------
354 -- pprSize: print a 'Size'
355
356 #if powerpc_TARGET_ARCH || i386_TARGET_ARCH || x86_64_TARGET_ARCH || sparc_TARGET_ARCH
357 pprSize :: MachRep -> Doc
358 #else
359 pprSize :: Size -> Doc
360 #endif
361
362 pprSize x = ptext (case x of
363 #if alpha_TARGET_ARCH
364 B -> SLIT("b")
365 Bu -> SLIT("bu")
366 -- W -> SLIT("w") UNUSED
367 -- Wu -> SLIT("wu") UNUSED
368 L -> SLIT("l")
369 Q -> SLIT("q")
370 -- FF -> SLIT("f") UNUSED
371 -- DF -> SLIT("d") UNUSED
372 -- GF -> SLIT("g") UNUSED
373 -- SF -> SLIT("s") UNUSED
374 TF -> SLIT("t")
375 #endif
376 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
377 I8 -> SLIT("b")
378 I16 -> SLIT("w")
379 I32 -> SLIT("l")
380 I64 -> SLIT("q")
381 #endif
382 #if i386_TARGET_ARCH
383 F32 -> SLIT("s")
384 F64 -> SLIT("l")
385 F80 -> SLIT("t")
386 #endif
387 #if x86_64_TARGET_ARCH
388 F32 -> SLIT("ss") -- "scalar single-precision float" (SSE2)
389 F64 -> SLIT("sd") -- "scalar double-precision float" (SSE2)
390 #endif
391 #if sparc_TARGET_ARCH
392 I8 -> SLIT("sb")
393 I16 -> SLIT("sh")
394 I32 -> SLIT("")
395 F32 -> SLIT("")
396 F64 -> SLIT("d")
397 )
398 pprStSize :: MachRep -> Doc
399 pprStSize x = ptext (case x of
400 I8 -> SLIT("b")
401 I16 -> SLIT("h")
402 I32 -> SLIT("")
403 F32 -> SLIT("")
404 F64 -> SLIT("d")
405 #endif
406 #if powerpc_TARGET_ARCH
407 I8 -> SLIT("b")
408 I16 -> SLIT("h")
409 I32 -> SLIT("w")
410 F32 -> SLIT("fs")
411 F64 -> SLIT("fd")
412 #endif
413 )
414
415 -- -----------------------------------------------------------------------------
416 -- pprCond: print a 'Cond'
417
418 pprCond :: Cond -> Doc
419
420 pprCond c = ptext (case c of {
421 #if alpha_TARGET_ARCH
422 EQQ -> SLIT("eq");
423 LTT -> SLIT("lt");
424 LE -> SLIT("le");
425 ULT -> SLIT("ult");
426 ULE -> SLIT("ule");
427 NE -> SLIT("ne");
428 GTT -> SLIT("gt");
429 GE -> SLIT("ge")
430 #endif
431 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
432 GEU -> SLIT("ae"); LU -> SLIT("b");
433 EQQ -> SLIT("e"); GTT -> SLIT("g");
434 GE -> SLIT("ge"); GU -> SLIT("a");
435 LTT -> SLIT("l"); LE -> SLIT("le");
436 LEU -> SLIT("be"); NE -> SLIT("ne");
437 NEG -> SLIT("s"); POS -> SLIT("ns");
438 CARRY -> SLIT("c"); OFLO -> SLIT("o");
439 PARITY -> SLIT("p"); NOTPARITY -> SLIT("np");
440 ALWAYS -> SLIT("mp") -- hack
441 #endif
442 #if sparc_TARGET_ARCH
443 ALWAYS -> SLIT(""); NEVER -> SLIT("n");
444 GEU -> SLIT("geu"); LU -> SLIT("lu");
445 EQQ -> SLIT("e"); GTT -> SLIT("g");
446 GE -> SLIT("ge"); GU -> SLIT("gu");
447 LTT -> SLIT("l"); LE -> SLIT("le");
448 LEU -> SLIT("leu"); NE -> SLIT("ne");
449 NEG -> SLIT("neg"); POS -> SLIT("pos");
450 VC -> SLIT("vc"); VS -> SLIT("vs")
451 #endif
452 #if powerpc_TARGET_ARCH
453 ALWAYS -> SLIT("");
454 EQQ -> SLIT("eq"); NE -> SLIT("ne");
455 LTT -> SLIT("lt"); GE -> SLIT("ge");
456 GTT -> SLIT("gt"); LE -> SLIT("le");
457 LU -> SLIT("lt"); GEU -> SLIT("ge");
458 GU -> SLIT("gt"); LEU -> SLIT("le");
459 #endif
460 })
461
462
463 -- -----------------------------------------------------------------------------
464 -- pprImm: print an 'Imm'
465
466 pprImm :: Imm -> Doc
467
468 pprImm (ImmInt i) = int i
469 pprImm (ImmInteger i) = integer i
470 pprImm (ImmCLbl l) = pprCLabel_asm l
471 pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i
472 pprImm (ImmLit s) = s
473
474 pprImm (ImmFloat _) = ptext SLIT("naughty float immediate")
475 pprImm (ImmDouble _) = ptext SLIT("naughty double immediate")
476
477 pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
478 #if sparc_TARGET_ARCH
479 -- ToDo: This should really be fixed in the PIC support, but only
480 -- print a for now.
481 pprImm (ImmConstantDiff a b) = pprImm a
482 #else
483 pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
484 <> lparen <> pprImm b <> rparen
485 #endif
486
487 #if sparc_TARGET_ARCH
488 pprImm (LO i)
489 = hcat [ pp_lo, pprImm i, rparen ]
490 where
491 pp_lo = text "%lo("
492
493 pprImm (HI i)
494 = hcat [ pp_hi, pprImm i, rparen ]
495 where
496 pp_hi = text "%hi("
497 #endif
498 #if powerpc_TARGET_ARCH
499 #if darwin_TARGET_OS
500 pprImm (LO i)
501 = hcat [ pp_lo, pprImm i, rparen ]
502 where
503 pp_lo = text "lo16("
504
505 pprImm (HI i)
506 = hcat [ pp_hi, pprImm i, rparen ]
507 where
508 pp_hi = text "hi16("
509
510 pprImm (HA i)
511 = hcat [ pp_ha, pprImm i, rparen ]
512 where
513 pp_ha = text "ha16("
514
515 #else
516 pprImm (LO i)
517 = pprImm i <> text "@l"
518
519 pprImm (HI i)
520 = pprImm i <> text "@h"
521
522 pprImm (HA i)
523 = pprImm i <> text "@ha"
524 #endif
525 #endif
526
527
528 -- -----------------------------------------------------------------------------
529 -- @pprAddr: print an 'AddrMode'
530
531 pprAddr :: AddrMode -> Doc
532
533 #if alpha_TARGET_ARCH
534 pprAddr (AddrReg r) = parens (pprReg r)
535 pprAddr (AddrImm i) = pprImm i
536 pprAddr (AddrRegImm r1 i)
537 = (<>) (pprImm i) (parens (pprReg r1))
538 #endif
539
540 -------------------
541
542 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
543 pprAddr (ImmAddr imm off)
544 = let pp_imm = pprImm imm
545 in
546 if (off == 0) then
547 pp_imm
548 else if (off < 0) then
549 pp_imm <> int off
550 else
551 pp_imm <> char '+' <> int off
552
553 pprAddr (AddrBaseIndex base index displacement)
554 = let
555 pp_disp = ppr_disp displacement
556 pp_off p = pp_disp <> char '(' <> p <> char ')'
557 pp_reg r = pprReg wordRep r
558 in
559 case (base,index) of
560 (EABaseNone, EAIndexNone) -> pp_disp
561 (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b)
562 (EABaseRip, EAIndexNone) -> pp_off (ptext SLIT("%rip"))
563 (EABaseNone, EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i)
564 (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r
565 <> comma <> int i)
566 where
567 ppr_disp (ImmInt 0) = empty
568 ppr_disp imm = pprImm imm
569 #endif
570
571 -------------------
572
573 #if sparc_TARGET_ARCH
574 pprAddr (AddrRegReg r1 (RealReg 0)) = pprReg r1
575
576 pprAddr (AddrRegReg r1 r2)
577 = hcat [ pprReg r1, char '+', pprReg r2 ]
578
579 pprAddr (AddrRegImm r1 (ImmInt i))
580 | i == 0 = pprReg r1
581 | not (fits13Bits i) = largeOffsetError i
582 | otherwise = hcat [ pprReg r1, pp_sign, int i ]
583 where
584 pp_sign = if i > 0 then char '+' else empty
585
586 pprAddr (AddrRegImm r1 (ImmInteger i))
587 | i == 0 = pprReg r1
588 | not (fits13Bits i) = largeOffsetError i
589 | otherwise = hcat [ pprReg r1, pp_sign, integer i ]
590 where
591 pp_sign = if i > 0 then char '+' else empty
592
593 pprAddr (AddrRegImm r1 imm)
594 = hcat [ pprReg r1, char '+', pprImm imm ]
595 #endif
596
597 -------------------
598
599 #if powerpc_TARGET_ARCH
600 pprAddr (AddrRegReg r1 r2)
601 = pprReg r1 <+> ptext SLIT(", ") <+> pprReg r2
602
603 pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ]
604 pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ]
605 pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]
606 #endif
607
608
609 -- -----------------------------------------------------------------------------
610 -- pprData: print a 'CmmStatic'
611
612 pprSectionHeader Text
613 = ptext
614 IF_ARCH_alpha(SLIT("\t.text\n\t.align 3") {-word boundary-}
615 ,IF_ARCH_sparc(SLIT(".text\n\t.align 4") {-word boundary-}
616 ,IF_ARCH_i386(IF_OS_darwin(SLIT(".text\n\t.align 2"),
617 SLIT(".text\n\t.align 4,0x90"))
618 {-needs per-OS variation!-}
619 ,IF_ARCH_x86_64(IF_OS_darwin(SLIT(".text\n.align 3"),
620 SLIT(".text\n\t.align 8"))
621 ,IF_ARCH_powerpc(SLIT(".text\n.align 2")
622 ,)))))
623 pprSectionHeader Data
624 = ptext
625 IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
626 ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
627 ,IF_ARCH_i386(IF_OS_darwin(SLIT(".data\n\t.align 2"),
628 SLIT(".data\n\t.align 4"))
629 ,IF_ARCH_x86_64(IF_OS_darwin(SLIT(".data\n.align 3"),
630 SLIT(".data\n\t.align 8"))
631 ,IF_ARCH_powerpc(SLIT(".data\n.align 2")
632 ,)))))
633 pprSectionHeader ReadOnlyData
634 = ptext
635 IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
636 ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
637 ,IF_ARCH_i386(IF_OS_darwin(SLIT(".const\n.align 2"),
638 SLIT(".section .rodata\n\t.align 4"))
639 ,IF_ARCH_x86_64(IF_OS_darwin(SLIT(".const\n.align 3"),
640 SLIT(".section .rodata\n\t.align 8"))
641 ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const\n.align 2"),
642 SLIT(".section .rodata\n\t.align 2"))
643 ,)))))
644 pprSectionHeader RelocatableReadOnlyData
645 = ptext
646 IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
647 ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
648 ,IF_ARCH_i386(IF_OS_darwin(SLIT(".const_data\n.align 2"),
649 SLIT(".section .rodata\n\t.align 4"))
650 ,IF_ARCH_x86_64(IF_OS_darwin(SLIT(".const_data\n.align 3"),
651 SLIT(".section .rodata\n\t.align 8"))
652 ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const_data\n.align 2"),
653 SLIT(".data\n\t.align 2"))
654 ,)))))
655 pprSectionHeader UninitialisedData
656 = ptext
657 IF_ARCH_alpha(SLIT("\t.bss\n\t.align 3")
658 ,IF_ARCH_sparc(SLIT(".bss\n\t.align 8") {-<8 will break double constants -}
659 ,IF_ARCH_i386(IF_OS_darwin(SLIT(".data\n\t.align 2"),
660 SLIT(".section .bss\n\t.align 4"))
661 ,IF_ARCH_x86_64(IF_OS_darwin(SLIT(".data\n\t.align 3"),
662 SLIT(".section .bss\n\t.align 8"))
663 ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const_data\n.align 2"),
664 SLIT(".section .bss\n\t.align 2"))
665 ,)))))
666 pprSectionHeader ReadOnlyData16
667 = ptext
668 IF_ARCH_alpha(SLIT("\t.data\n\t.align 4")
669 ,IF_ARCH_sparc(SLIT(".data\n\t.align 16")
670 ,IF_ARCH_i386(IF_OS_darwin(SLIT(".const\n.align 4"),
671 SLIT(".section .rodata\n\t.align 16"))
672 ,IF_ARCH_x86_64(IF_OS_darwin(SLIT(".const\n.align 4"),
673 SLIT(".section .rodata.cst16\n\t.align 16"))
674 ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const\n.align 4"),
675 SLIT(".section .rodata\n\t.align 4"))
676 ,)))))
677
678 pprSectionHeader (OtherSection sec)
679 = panic "PprMach.pprSectionHeader: unknown section"
680
681 pprData :: CmmStatic -> Doc
682 pprData (CmmAlign bytes) = pprAlign bytes
683 pprData (CmmDataLabel lbl) = pprLabel lbl
684 pprData (CmmString str) = pprASCII str
685 pprData (CmmUninitialised bytes) = ptext SLIT(".space ") <> int bytes
686 pprData (CmmStaticLit lit) = pprDataItem lit
687
688 pprGloblDecl :: CLabel -> Doc
689 pprGloblDecl lbl
690 | not (externallyVisibleCLabel lbl) = empty
691 | otherwise = ptext IF_ARCH_sparc(SLIT(".global "),
692 SLIT(".globl ")) <>
693 pprCLabel_asm lbl
694
695 pprLabel :: CLabel -> Doc
696 pprLabel lbl = pprGloblDecl lbl $$ (pprCLabel_asm lbl <> char ':')
697
698
699 pprASCII str
700 = vcat (map do1 str) $$ do1 0
701 where
702 do1 :: Word8 -> Doc
703 do1 w = ptext SLIT("\t.byte\t") <> int (fromIntegral w)
704
705 pprAlign bytes =
706 IF_ARCH_alpha(ptextSLIT(".align ") <> int pow2,
707 IF_ARCH_i386(ptext SLIT(".align ") <> int IF_OS_darwin(pow2,bytes),
708 IF_ARCH_x86_64(ptext SLIT(".align ") <> int IF_OS_darwin(pow2,bytes),
709 IF_ARCH_sparc(ptext SLIT(".align ") <> int bytes,
710 IF_ARCH_powerpc(ptext SLIT(".align ") <> int pow2,)))))
711 where
712 pow2 = log2 bytes
713
714 log2 :: Int -> Int -- cache the common ones
715 log2 1 = 0
716 log2 2 = 1
717 log2 4 = 2
718 log2 8 = 3
719 log2 n = 1 + log2 (n `quot` 2)
720
721
722 pprDataItem :: CmmLit -> Doc
723 pprDataItem lit
724 = vcat (ppr_item (cmmLitRep lit) lit)
725 where
726 imm = litToImm lit
727
728 -- These seem to be common:
729 ppr_item I8 x = [ptext SLIT("\t.byte\t") <> pprImm imm]
730 ppr_item I32 x = [ptext SLIT("\t.long\t") <> pprImm imm]
731 ppr_item F32 (CmmFloat r _)
732 = let bs = floatToBytes (fromRational r)
733 in map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
734 ppr_item F64 (CmmFloat r _)
735 = let bs = doubleToBytes (fromRational r)
736 in map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
737
738 #if sparc_TARGET_ARCH
739 -- copy n paste of x86 version
740 ppr_item I16 x = [ptext SLIT("\t.short\t") <> pprImm imm]
741 ppr_item I64 x = [ptext SLIT("\t.quad\t") <> pprImm imm]
742 #endif
743 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
744 ppr_item I16 x = [ptext SLIT("\t.word\t") <> pprImm imm]
745 #endif
746 #if i386_TARGET_ARCH && darwin_TARGET_OS
747 ppr_item I64 (CmmInt x _) =
748 [ptext SLIT("\t.long\t")
749 <> int (fromIntegral (fromIntegral x :: Word32)),
750 ptext SLIT("\t.long\t")
751 <> int (fromIntegral
752 (fromIntegral (x `shiftR` 32) :: Word32))]
753 #endif
754 #if i386_TARGET_ARCH || (darwin_TARGET_OS && x86_64_TARGET_ARCH)
755 ppr_item I64 x = [ptext SLIT("\t.quad\t") <> pprImm imm]
756 #endif
757 #if x86_64_TARGET_ARCH && !darwin_TARGET_OS
758 -- x86_64: binutils can't handle the R_X86_64_PC64 relocation
759 -- type, which means we can't do pc-relative 64-bit addresses.
760 -- Fortunately we're assuming the small memory model, in which
761 -- all such offsets will fit into 32 bits, so we have to stick
762 -- to 32-bit offset fields and modify the RTS appropriately
763 -- (see InfoTables.h).
764 --
765 ppr_item I64 x
766 | isRelativeReloc x =
767 [ptext SLIT("\t.long\t") <> pprImm imm,
768 ptext SLIT("\t.long\t0")]
769 | otherwise =
770 [ptext SLIT("\t.quad\t") <> pprImm imm]
771 where
772 isRelativeReloc (CmmLabelOff _ _) = True
773 isRelativeReloc (CmmLabelDiffOff _ _ _) = True
774 isRelativeReloc _ = False
775 #endif
776 #if powerpc_TARGET_ARCH
777 ppr_item I16 x = [ptext SLIT("\t.short\t") <> pprImm imm]
778 ppr_item I64 (CmmInt x _) =
779 [ptext SLIT("\t.long\t")
780 <> int (fromIntegral
781 (fromIntegral (x `shiftR` 32) :: Word32)),
782 ptext SLIT("\t.long\t")
783 <> int (fromIntegral (fromIntegral x :: Word32))]
784 #endif
785
786 -- fall through to rest of (machine-specific) pprInstr...
787
788 -- -----------------------------------------------------------------------------
789 -- pprInstr: print an 'Instr'
790
791 pprInstr :: Instr -> Doc
792
793 --pprInstr (COMMENT s) = empty -- nuke 'em
794 pprInstr (COMMENT s)
795 = IF_ARCH_alpha( ((<>) (ptext SLIT("\t# ")) (ftext s))
796 ,IF_ARCH_sparc( ((<>) (ptext SLIT("! ")) (ftext s))
797 ,IF_ARCH_i386( ((<>) (ptext SLIT("# ")) (ftext s))
798 ,IF_ARCH_x86_64( ((<>) (ptext SLIT("# ")) (ftext s))
799 ,IF_ARCH_powerpc( IF_OS_linux(
800 ((<>) (ptext SLIT("# ")) (ftext s)),
801 ((<>) (ptext SLIT("; ")) (ftext s)))
802 ,)))))
803
804 pprInstr (DELTA d)
805 = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
806
807 pprInstr (NEWBLOCK _)
808 = panic "PprMach.pprInstr: NEWBLOCK"
809
810 pprInstr (LDATA _ _)
811 = panic "PprMach.pprInstr: LDATA"
812
813 -- -----------------------------------------------------------------------------
814 -- pprInstr for an Alpha
815
816 #if alpha_TARGET_ARCH
817
818 pprInstr (LD size reg addr)
819 = hcat [
820 ptext SLIT("\tld"),
821 pprSize size,
822 char '\t',
823 pprReg reg,
824 comma,
825 pprAddr addr
826 ]
827
828 pprInstr (LDA reg addr)
829 = hcat [
830 ptext SLIT("\tlda\t"),
831 pprReg reg,
832 comma,
833 pprAddr addr
834 ]
835
836 pprInstr (LDAH reg addr)
837 = hcat [
838 ptext SLIT("\tldah\t"),
839 pprReg reg,
840 comma,
841 pprAddr addr
842 ]
843
844 pprInstr (LDGP reg addr)
845 = hcat [
846 ptext SLIT("\tldgp\t"),
847 pprReg reg,
848 comma,
849 pprAddr addr
850 ]
851
852 pprInstr (LDI size reg imm)
853 = hcat [
854 ptext SLIT("\tldi"),
855 pprSize size,
856 char '\t',
857 pprReg reg,
858 comma,
859 pprImm imm
860 ]
861
862 pprInstr (ST size reg addr)
863 = hcat [
864 ptext SLIT("\tst"),
865 pprSize size,
866 char '\t',
867 pprReg reg,
868 comma,
869 pprAddr addr
870 ]
871
872 pprInstr (CLR reg)
873 = hcat [
874 ptext SLIT("\tclr\t"),
875 pprReg reg
876 ]
877
878 pprInstr (ABS size ri reg)
879 = hcat [
880 ptext SLIT("\tabs"),
881 pprSize size,
882 char '\t',
883 pprRI ri,
884 comma,
885 pprReg reg
886 ]
887
888 pprInstr (NEG size ov ri reg)
889 = hcat [
890 ptext SLIT("\tneg"),
891 pprSize size,
892 if ov then ptext SLIT("v\t") else char '\t',
893 pprRI ri,
894 comma,
895 pprReg reg
896 ]
897
898 pprInstr (ADD size ov reg1 ri reg2)
899 = hcat [
900 ptext SLIT("\tadd"),
901 pprSize size,
902 if ov then ptext SLIT("v\t") else char '\t',
903 pprReg reg1,
904 comma,
905 pprRI ri,
906 comma,
907 pprReg reg2
908 ]
909
910 pprInstr (SADD size scale reg1 ri reg2)
911 = hcat [
912 ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
913 ptext SLIT("add"),
914 pprSize size,
915 char '\t',
916 pprReg reg1,
917 comma,
918 pprRI ri,
919 comma,
920 pprReg reg2
921 ]
922
923 pprInstr (SUB size ov reg1 ri reg2)
924 = hcat [
925 ptext SLIT("\tsub"),
926 pprSize size,
927 if ov then ptext SLIT("v\t") else char '\t',
928 pprReg reg1,
929 comma,
930 pprRI ri,
931 comma,
932 pprReg reg2
933 ]
934
935 pprInstr (SSUB size scale reg1 ri reg2)
936 = hcat [
937 ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
938 ptext SLIT("sub"),
939 pprSize size,
940 char '\t',
941 pprReg reg1,
942 comma,
943 pprRI ri,
944 comma,
945 pprReg reg2
946 ]
947
948 pprInstr (MUL size ov reg1 ri reg2)
949 = hcat [
950 ptext SLIT("\tmul"),
951 pprSize size,
952 if ov then ptext SLIT("v\t") else char '\t',
953 pprReg reg1,
954 comma,
955 pprRI ri,
956 comma,
957 pprReg reg2
958 ]
959
960 pprInstr (DIV size uns reg1 ri reg2)
961 = hcat [
962 ptext SLIT("\tdiv"),
963 pprSize size,
964 if uns then ptext SLIT("u\t") else char '\t',
965 pprReg reg1,
966 comma,
967 pprRI ri,
968 comma,
969 pprReg reg2
970 ]
971
972 pprInstr (REM size uns reg1 ri reg2)
973 = hcat [
974 ptext SLIT("\trem"),
975 pprSize size,
976 if uns then ptext SLIT("u\t") else char '\t',
977 pprReg reg1,
978 comma,
979 pprRI ri,
980 comma,
981 pprReg reg2
982 ]
983
984 pprInstr (NOT ri reg)
985 = hcat [
986 ptext SLIT("\tnot"),
987 char '\t',
988 pprRI ri,
989 comma,
990 pprReg reg
991 ]
992
993 pprInstr (AND reg1 ri reg2) = pprRegRIReg SLIT("and") reg1 ri reg2
994 pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg SLIT("andnot") reg1 ri reg2
995 pprInstr (OR reg1 ri reg2) = pprRegRIReg SLIT("or") reg1 ri reg2
996 pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg SLIT("ornot") reg1 ri reg2
997 pprInstr (XOR reg1 ri reg2) = pprRegRIReg SLIT("xor") reg1 ri reg2
998 pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg SLIT("xornot") reg1 ri reg2
999
1000 pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") reg1 ri reg2
1001 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") reg1 ri reg2
1002 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") reg1 ri reg2
1003
1004 pprInstr (ZAP reg1 ri reg2) = pprRegRIReg SLIT("zap") reg1 ri reg2
1005 pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg SLIT("zapnot") reg1 ri reg2
1006
1007 pprInstr (NOP) = ptext SLIT("\tnop")
1008
1009 pprInstr (CMP cond reg1 ri reg2)
1010 = hcat [
1011 ptext SLIT("\tcmp"),
1012 pprCond cond,
1013 char '\t',
1014 pprReg reg1,
1015 comma,
1016 pprRI ri,
1017 comma,
1018 pprReg reg2
1019 ]
1020
1021 pprInstr (FCLR reg)
1022 = hcat [
1023 ptext SLIT("\tfclr\t"),
1024 pprReg reg
1025 ]
1026
1027 pprInstr (FABS reg1 reg2)
1028 = hcat [
1029 ptext SLIT("\tfabs\t"),
1030 pprReg reg1,
1031 comma,
1032 pprReg reg2
1033 ]
1034
1035 pprInstr (FNEG size reg1 reg2)
1036 = hcat [
1037 ptext SLIT("\tneg"),
1038 pprSize size,
1039 char '\t',
1040 pprReg reg1,
1041 comma,
1042 pprReg reg2
1043 ]
1044
1045 pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("add") size reg1 reg2 reg3
1046 pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("div") size reg1 reg2 reg3
1047 pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("mul") size reg1 reg2 reg3
1048 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("sub") size reg1 reg2 reg3
1049
1050 pprInstr (CVTxy size1 size2 reg1 reg2)
1051 = hcat [
1052 ptext SLIT("\tcvt"),
1053 pprSize size1,
1054 case size2 of {Q -> ptext SLIT("qc"); _ -> pprSize size2},
1055 char '\t',
1056 pprReg reg1,
1057 comma,
1058 pprReg reg2
1059 ]
1060
1061 pprInstr (FCMP size cond reg1 reg2 reg3)
1062 = hcat [
1063 ptext SLIT("\tcmp"),
1064 pprSize size,
1065 pprCond cond,
1066 char '\t',
1067 pprReg reg1,
1068 comma,
1069 pprReg reg2,
1070 comma,
1071 pprReg reg3
1072 ]
1073
1074 pprInstr (FMOV reg1 reg2)
1075 = hcat [
1076 ptext SLIT("\tfmov\t"),
1077 pprReg reg1,
1078 comma,
1079 pprReg reg2
1080 ]
1081
1082 pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
1083
1084 pprInstr (BI NEVER reg lab) = empty
1085
1086 pprInstr (BI cond reg lab)
1087 = hcat [
1088 ptext SLIT("\tb"),
1089 pprCond cond,
1090 char '\t',
1091 pprReg reg,
1092 comma,
1093 pprImm lab
1094 ]
1095
1096 pprInstr (BF cond reg lab)
1097 = hcat [
1098 ptext SLIT("\tfb"),
1099 pprCond cond,
1100 char '\t',
1101 pprReg reg,
1102 comma,
1103 pprImm lab
1104 ]
1105
1106 pprInstr (BR lab)
1107 = (<>) (ptext SLIT("\tbr\t")) (pprImm lab)
1108
1109 pprInstr (JMP reg addr hint)
1110 = hcat [
1111 ptext SLIT("\tjmp\t"),
1112 pprReg reg,
1113 comma,
1114 pprAddr addr,
1115 comma,
1116 int hint
1117 ]
1118
1119 pprInstr (BSR imm n)
1120 = (<>) (ptext SLIT("\tbsr\t")) (pprImm imm)
1121
1122 pprInstr (JSR reg addr n)
1123 = hcat [
1124 ptext SLIT("\tjsr\t"),
1125 pprReg reg,
1126 comma,
1127 pprAddr addr
1128 ]
1129
1130 pprInstr (FUNBEGIN clab)
1131 = hcat [
1132 if (externallyVisibleCLabel clab) then
1133 hcat [ptext SLIT("\t.globl\t"), pp_lab, char '\n']
1134 else
1135 empty,
1136 ptext SLIT("\t.ent "),
1137 pp_lab,
1138 char '\n',
1139 pp_lab,
1140 pp_ldgp,
1141 pp_lab,
1142 pp_frame
1143 ]
1144 where
1145 pp_lab = pprCLabel_asm clab
1146
1147 -- NEVER use commas within those string literals, cpp will ruin your day
1148 pp_ldgp = hcat [ ptext SLIT(":\n\tldgp $29"), char ',', ptext SLIT("0($27)\n") ]
1149 pp_frame = hcat [ ptext SLIT("..ng:\n\t.frame $30"), char ',',
1150 ptext SLIT("4240"), char ',',
1151 ptext SLIT("$26"), char ',',
1152 ptext SLIT("0\n\t.prologue 1") ]
1153
1154 pprInstr (FUNEND clab)
1155 = (<>) (ptext SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab)
1156 \end{code}
1157
1158 Continue with Alpha-only printing bits and bobs:
1159 \begin{code}
1160 pprRI :: RI -> Doc
1161
1162 pprRI (RIReg r) = pprReg r
1163 pprRI (RIImm r) = pprImm r
1164
1165 pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
1166 pprRegRIReg name reg1 ri reg2
1167 = hcat [
1168 char '\t',
1169 ptext name,
1170 char '\t',
1171 pprReg reg1,
1172 comma,
1173 pprRI ri,
1174 comma,
1175 pprReg reg2
1176 ]
1177
1178 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1179 pprSizeRegRegReg name size reg1 reg2 reg3
1180 = hcat [
1181 char '\t',
1182 ptext name,
1183 pprSize size,
1184 char '\t',
1185 pprReg reg1,
1186 comma,
1187 pprReg reg2,
1188 comma,
1189 pprReg reg3
1190 ]
1191
1192 #endif /* alpha_TARGET_ARCH */
1193
1194
1195 -- -----------------------------------------------------------------------------
1196 -- pprInstr for an x86
1197
1198 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1199
1200 pprInstr v@(MOV size s@(OpReg src) d@(OpReg dst)) -- hack
1201 | src == dst
1202 =
1203 #if 0 /* #ifdef DEBUG */
1204 (<>) (ptext SLIT("# warning: ")) (pprSizeOpOp SLIT("mov") size s d)
1205 #else
1206 empty
1207 #endif
1208
1209 pprInstr (MOV size src dst)
1210 = pprSizeOpOp SLIT("mov") size src dst
1211
1212 pprInstr (MOVZxL I32 src dst) = pprSizeOpOp SLIT("mov") I32 src dst
1213 -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple
1214 -- movl. But we represent it as a MOVZxL instruction, because
1215 -- the reg alloc would tend to throw away a plain reg-to-reg
1216 -- move, and we still want it to do that.
1217
1218 pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce SLIT("movz") sizes I32 src dst
1219 -- zero-extension only needs to extend to 32 bits: on x86_64,
1220 -- the remaining zero-extension to 64 bits is automatic, and the 32-bit
1221 -- instruction is shorter.
1222
1223 pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce SLIT("movs") sizes wordRep src dst
1224
1225 -- here we do some patching, since the physical registers are only set late
1226 -- in the code generation.
1227 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1228 | reg1 == reg3
1229 = pprSizeOpOp SLIT("add") size (OpReg reg2) dst
1230 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1231 | reg2 == reg3
1232 = pprSizeOpOp SLIT("add") size (OpReg reg1) dst
1233 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))
1234 | reg1 == reg3
1235 = pprInstr (ADD size (OpImm displ) dst)
1236 pprInstr (LEA size src dst) = pprSizeOpOp SLIT("lea") size src dst
1237
1238 pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
1239 = pprSizeOp SLIT("dec") size dst
1240 pprInstr (ADD size (OpImm (ImmInt 1)) dst)
1241 = pprSizeOp SLIT("inc") size dst
1242 pprInstr (ADD size src dst)
1243 = pprSizeOpOp SLIT("add") size src dst
1244 pprInstr (ADC size src dst)
1245 = pprSizeOpOp SLIT("adc") size src dst
1246 pprInstr (SUB size src dst) = pprSizeOpOp SLIT("sub") size src dst
1247 pprInstr (IMUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2
1248
1249 {- A hack. The Intel documentation says that "The two and three
1250 operand forms [of IMUL] may also be used with unsigned operands
1251 because the lower half of the product is the same regardless if
1252 (sic) the operands are signed or unsigned. The CF and OF flags,
1253 however, cannot be used to determine if the upper half of the
1254 result is non-zero." So there.
1255 -}
1256 pprInstr (AND size src dst) = pprSizeOpOp SLIT("and") size src dst
1257 pprInstr (OR size src dst) = pprSizeOpOp SLIT("or") size src dst
1258
1259 pprInstr (XOR F32 src dst) = pprOpOp SLIT("xorps") F32 src dst
1260 pprInstr (XOR F64 src dst) = pprOpOp SLIT("xorpd") F64 src dst
1261 pprInstr (XOR size src dst) = pprSizeOpOp SLIT("xor") size src dst
1262
1263 pprInstr (NOT size op) = pprSizeOp SLIT("not") size op
1264 pprInstr (NEGI size op) = pprSizeOp SLIT("neg") size op
1265
1266 pprInstr (SHL size src dst) = pprShift SLIT("shl") size src dst
1267 pprInstr (SAR size src dst) = pprShift SLIT("sar") size src dst
1268 pprInstr (SHR size src dst) = pprShift SLIT("shr") size src dst
1269
1270 pprInstr (BT size imm src) = pprSizeImmOp SLIT("bt") size imm src
1271
1272 pprInstr (CMP size src dst)
1273 | isFloatingRep size = pprSizeOpOp SLIT("ucomi") size src dst -- SSE2
1274 | otherwise = pprSizeOpOp SLIT("cmp") size src dst
1275
1276 pprInstr (TEST size src dst) = pprSizeOpOp SLIT("test") size src dst
1277 pprInstr (PUSH size op) = pprSizeOp SLIT("push") size op
1278 pprInstr (POP size op) = pprSizeOp SLIT("pop") size op
1279
1280 -- both unused (SDM):
1281 -- pprInstr PUSHA = ptext SLIT("\tpushal")
1282 -- pprInstr POPA = ptext SLIT("\tpopal")
1283
1284 pprInstr NOP = ptext SLIT("\tnop")
1285 pprInstr (CLTD I32) = ptext SLIT("\tcltd")
1286 pprInstr (CLTD I64) = ptext SLIT("\tcqto")
1287
1288 pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand I8 op)
1289
1290 pprInstr (JXX cond (BlockId id))
1291 = pprCondInstr SLIT("j") cond (pprCLabel_asm lab)
1292 where lab = mkAsmTempLabel id
1293
1294 pprInstr (JMP (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
1295 pprInstr (JMP op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand wordRep op)
1296 pprInstr (JMP_TBL op ids) = pprInstr (JMP op)
1297 pprInstr (CALL (Left imm) _) = (<>) (ptext SLIT("\tcall ")) (pprImm imm)
1298 pprInstr (CALL (Right reg) _) = (<>) (ptext SLIT("\tcall *")) (pprReg wordRep reg)
1299
1300 pprInstr (IDIV sz op) = pprSizeOp SLIT("idiv") sz op
1301 pprInstr (DIV sz op) = pprSizeOp SLIT("div") sz op
1302 pprInstr (IMUL2 sz op) = pprSizeOp SLIT("imul") sz op
1303
1304 #if x86_64_TARGET_ARCH
1305 pprInstr (MUL size op1 op2) = pprSizeOpOp SLIT("mul") size op1 op2
1306
1307 pprInstr (FDIV size op1 op2) = pprSizeOpOp SLIT("div") size op1 op2
1308
1309 pprInstr (CVTSS2SD from to) = pprRegReg SLIT("cvtss2sd") from to
1310 pprInstr (CVTSD2SS from to) = pprRegReg SLIT("cvtsd2ss") from to
1311 pprInstr (CVTSS2SI from to) = pprOpReg SLIT("cvtss2siq") from to
1312 pprInstr (CVTSD2SI from to) = pprOpReg SLIT("cvtsd2siq") from to
1313 pprInstr (CVTSI2SS from to) = pprOpReg SLIT("cvtsi2ssq") from to
1314 pprInstr (CVTSI2SD from to) = pprOpReg SLIT("cvtsi2sdq") from to
1315 #endif
1316
1317 -- FETCHGOT for PIC on ELF platforms
1318 pprInstr (FETCHGOT reg)
1319 = vcat [ ptext SLIT("\tcall 1f"),
1320 hcat [ ptext SLIT("1:\tpopl\t"), pprReg I32 reg ],
1321 hcat [ ptext SLIT("\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "),
1322 pprReg I32 reg ]
1323 ]
1324
1325 -- FETCHPC for PIC on Darwin/x86
1326 -- get the instruction pointer into a register
1327 -- (Terminology note: the IP is called Program Counter on PPC,
1328 -- and it's a good thing to use the same name on both platforms)
1329 pprInstr (FETCHPC reg)
1330 = vcat [ ptext SLIT("\tcall 1f"),
1331 hcat [ ptext SLIT("1:\tpopl\t"), pprReg I32 reg ]
1332 ]
1333
1334
1335
1336 #endif
1337
1338 -- -----------------------------------------------------------------------------
1339 -- i386 floating-point
1340
1341 #if i386_TARGET_ARCH
1342 -- Simulating a flat register set on the x86 FP stack is tricky.
1343 -- you have to free %st(7) before pushing anything on the FP reg stack
1344 -- so as to preclude the possibility of a FP stack overflow exception.
1345 pprInstr g@(GMOV src dst)
1346 | src == dst
1347 = empty
1348 | otherwise
1349 = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
1350
1351 -- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FSTP (dst+1)
1352 pprInstr g@(GLD sz addr dst)
1353 = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp,
1354 pprAddr addr, gsemi, gpop dst 1])
1355
1356 -- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
1357 pprInstr g@(GST sz src addr)
1358 = pprG g (hcat [gtab, gpush src 0, gsemi,
1359 text "fstp", pprSize sz, gsp, pprAddr addr])
1360
1361 pprInstr g@(GLDZ dst)
1362 = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1])
1363 pprInstr g@(GLD1 dst)
1364 = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1])
1365
1366 pprInstr g@(GFTOI src dst)
1367 = pprInstr (GDTOI src dst)
1368 pprInstr g@(GDTOI src dst)
1369 = pprG g (hcat [gtab, text "subl $4, %esp ; ",
1370 gpush src 0, gsemi, text "fistpl 0(%esp) ; popl ",
1371 pprReg I32 dst])
1372
1373 pprInstr g@(GITOF src dst)
1374 = pprInstr (GITOD src dst)
1375 pprInstr g@(GITOD src dst)
1376 = pprG g (hcat [gtab, text "pushl ", pprReg I32 src,
1377 text " ; ffree %st(7); fildl (%esp) ; ",
1378 gpop dst 1, text " ; addl $4,%esp"])
1379
1380 {- Gruesome swamp follows. If you're unfortunate enough to have ventured
1381 this far into the jungle AND you give a Rat's Ass (tm) what's going
1382 on, here's the deal. Generate code to do a floating point comparison
1383 of src1 and src2, of kind cond, and set the Zero flag if true.
1384
1385 The complications are to do with handling NaNs correctly. We want the
1386 property that if either argument is NaN, then the result of the
1387 comparison is False ... except if we're comparing for inequality,
1388 in which case the answer is True.
1389
1390 Here's how the general (non-inequality) case works. As an
1391 example, consider generating the an equality test:
1392
1393 pushl %eax -- we need to mess with this
1394 <get src1 to top of FPU stack>
1395 fcomp <src2 location in FPU stack> and pop pushed src1
1396 -- Result of comparison is in FPU Status Register bits
1397 -- C3 C2 and C0
1398 fstsw %ax -- Move FPU Status Reg to %ax
1399 sahf -- move C3 C2 C0 from %ax to integer flag reg
1400 -- now the serious magic begins
1401 setpo %ah -- %ah = if comparable(neither arg was NaN) then 1 else 0
1402 sete %al -- %al = if arg1 == arg2 then 1 else 0
1403 andb %ah,%al -- %al &= %ah
1404 -- so %al == 1 iff (comparable && same); else it holds 0
1405 decb %al -- %al == 0, ZeroFlag=1 iff (comparable && same);
1406 else %al == 0xFF, ZeroFlag=0
1407 -- the zero flag is now set as we desire.
1408 popl %eax
1409
1410 The special case of inequality differs thusly:
1411
1412 setpe %ah -- %ah = if incomparable(either arg was NaN) then 1 else 0
1413 setne %al -- %al = if arg1 /= arg2 then 1 else 0
1414 orb %ah,%al -- %al = if (incomparable || different) then 1 else 0
1415 decb %al -- if (incomparable || different) then (%al == 0, ZF=1)
1416 else (%al == 0xFF, ZF=0)
1417 -}
1418 pprInstr g@(GCMP cond src1 src2)
1419 | case cond of { NE -> True; other -> False }
1420 = pprG g (vcat [
1421 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1422 hcat [gtab, text "fcomp ", greg src2 1,
1423 text "; fstsw %ax ; sahf ; setpe %ah"],
1424 hcat [gtab, text "setne %al ; ",
1425 text "orb %ah,%al ; decb %al ; popl %eax"]
1426 ])
1427 | otherwise
1428 = pprG g (vcat [
1429 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1430 hcat [gtab, text "fcomp ", greg src2 1,
1431 text "; fstsw %ax ; sahf ; setpo %ah"],
1432 hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ; ",
1433 text "andb %ah,%al ; decb %al ; popl %eax"]
1434 ])
1435 where
1436 {- On the 486, the flags set by FP compare are the unsigned ones!
1437 (This looks like a HACK to me. WDP 96/03)
1438 -}
1439 fix_FP_cond :: Cond -> Cond
1440 fix_FP_cond GE = GEU
1441 fix_FP_cond GTT = GU
1442 fix_FP_cond LTT = LU
1443 fix_FP_cond LE = LEU
1444 fix_FP_cond EQQ = EQQ
1445 fix_FP_cond NE = NE
1446 -- there should be no others
1447
1448
1449 pprInstr g@(GABS sz src dst)
1450 = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
1451 pprInstr g@(GNEG sz src dst)
1452 = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
1453
1454 pprInstr g@(GSQRT sz src dst)
1455 = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
1456 hcat [gtab, gcoerceto sz, gpop dst 1])
1457 pprInstr g@(GSIN sz src dst)
1458 = pprG g (hcat [gtab, gpush src 0, text " ; fsin"] $$
1459 hcat [gtab, gcoerceto sz, gpop dst 1])
1460 pprInstr g@(GCOS sz src dst)
1461 = pprG g (hcat [gtab, gpush src 0, text " ; fcos"] $$
1462 hcat [gtab, gcoerceto sz, gpop dst 1])
1463 pprInstr g@(GTAN sz src dst)
1464 = pprG g (hcat [gtab, text "ffree %st(6) ; ",
1465 gpush src 0, text " ; fptan ; ",
1466 text " fstp %st(0)"] $$
1467 hcat [gtab, gcoerceto sz, gpop dst 1])
1468
1469 -- In the translations for GADD, GMUL, GSUB and GDIV,
1470 -- the first two cases are mere optimisations. The otherwise clause
1471 -- generates correct code under all circumstances.
1472
1473 pprInstr g@(GADD sz src1 src2 dst)
1474 | src1 == dst
1475 = pprG g (text "\t#GADD-xxxcase1" $$
1476 hcat [gtab, gpush src2 0,
1477 text " ; faddp %st(0),", greg src1 1])
1478 | src2 == dst
1479 = pprG g (text "\t#GADD-xxxcase2" $$
1480 hcat [gtab, gpush src1 0,
1481 text " ; faddp %st(0),", greg src2 1])
1482 | otherwise
1483 = pprG g (hcat [gtab, gpush src1 0,
1484 text " ; fadd ", greg src2 1, text ",%st(0)",
1485 gsemi, gpop dst 1])
1486
1487
1488 pprInstr g@(GMUL sz src1 src2 dst)
1489 | src1 == dst
1490 = pprG g (text "\t#GMUL-xxxcase1" $$
1491 hcat [gtab, gpush src2 0,
1492 text " ; fmulp %st(0),", greg src1 1])
1493 | src2 == dst
1494 = pprG g (text "\t#GMUL-xxxcase2" $$
1495 hcat [gtab, gpush src1 0,
1496 text " ; fmulp %st(0),", greg src2 1])
1497 | otherwise
1498 = pprG g (hcat [gtab, gpush src1 0,
1499 text " ; fmul ", greg src2 1, text ",%st(0)",
1500 gsemi, gpop dst 1])
1501
1502
1503 pprInstr g@(GSUB sz src1 src2 dst)
1504 | src1 == dst
1505 = pprG g (text "\t#GSUB-xxxcase1" $$
1506 hcat [gtab, gpush src2 0,
1507 text " ; fsubrp %st(0),", greg src1 1])
1508 | src2 == dst
1509 = pprG g (text "\t#GSUB-xxxcase2" $$
1510 hcat [gtab, gpush src1 0,
1511 text " ; fsubp %st(0),", greg src2 1])
1512 | otherwise
1513 = pprG g (hcat [gtab, gpush src1 0,
1514 text " ; fsub ", greg src2 1, text ",%st(0)",
1515 gsemi, gpop dst 1])
1516
1517
1518 pprInstr g@(GDIV sz src1 src2 dst)
1519 | src1 == dst
1520 = pprG g (text "\t#GDIV-xxxcase1" $$
1521 hcat [gtab, gpush src2 0,
1522 text " ; fdivrp %st(0),", greg src1 1])
1523 | src2 == dst
1524 = pprG g (text "\t#GDIV-xxxcase2" $$
1525 hcat [gtab, gpush src1 0,
1526 text " ; fdivp %st(0),", greg src2 1])
1527 | otherwise
1528 = pprG g (hcat [gtab, gpush src1 0,
1529 text " ; fdiv ", greg src2 1, text ",%st(0)",
1530 gsemi, gpop dst 1])
1531
1532
1533 pprInstr GFREE
1534 = vcat [ ptext SLIT("\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
1535 ptext SLIT("\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)")
1536 ]
1537
1538 --------------------------
1539
1540 -- coerce %st(0) to the specified size
1541 gcoerceto F64 = empty
1542 gcoerceto F32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
1543
1544 gpush reg offset
1545 = hcat [text "ffree %st(7) ; fld ", greg reg offset]
1546 gpop reg offset
1547 = hcat [text "fstp ", greg reg offset]
1548
1549 greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
1550 gsemi = text " ; "
1551 gtab = char '\t'
1552 gsp = char ' '
1553
1554 gregno (RealReg i) = i
1555 gregno other = --pprPanic "gregno" (ppr other)
1556 999 -- bogus; only needed for debug printing
1557
1558 pprG :: Instr -> Doc -> Doc
1559 pprG fake actual
1560 = (char '#' <> pprGInstr fake) $$ actual
1561
1562 pprGInstr (GMOV src dst) = pprSizeRegReg SLIT("gmov") F64 src dst
1563 pprGInstr (GLD sz src dst) = pprSizeAddrReg SLIT("gld") sz src dst
1564 pprGInstr (GST sz src dst) = pprSizeRegAddr SLIT("gst") sz src dst
1565
1566 pprGInstr (GLDZ dst) = pprSizeReg SLIT("gldz") F64 dst
1567 pprGInstr (GLD1 dst) = pprSizeReg SLIT("gld1") F64 dst
1568
1569 pprGInstr (GFTOI src dst) = pprSizeSizeRegReg SLIT("gftoi") F32 I32 src dst
1570 pprGInstr (GDTOI src dst) = pprSizeSizeRegReg SLIT("gdtoi") F64 I32 src dst
1571
1572 pprGInstr (GITOF src dst) = pprSizeSizeRegReg SLIT("gitof") I32 F32 src dst
1573 pprGInstr (GITOD src dst) = pprSizeSizeRegReg SLIT("gitod") I32 F64 src dst
1574
1575 pprGInstr (GCMP co src dst) = pprCondRegReg SLIT("gcmp_") F64 co src dst
1576 pprGInstr (GABS sz src dst) = pprSizeRegReg SLIT("gabs") sz src dst
1577 pprGInstr (GNEG sz src dst) = pprSizeRegReg SLIT("gneg") sz src dst
1578 pprGInstr (GSQRT sz src dst) = pprSizeRegReg SLIT("gsqrt") sz src dst
1579 pprGInstr (GSIN sz src dst) = pprSizeRegReg SLIT("gsin") sz src dst
1580 pprGInstr (GCOS sz src dst) = pprSizeRegReg SLIT("gcos") sz src dst
1581 pprGInstr (GTAN sz src dst) = pprSizeRegReg SLIT("gtan") sz src dst
1582
1583 pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg SLIT("gadd") sz src1 src2 dst
1584 pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg SLIT("gsub") sz src1 src2 dst
1585 pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg SLIT("gmul") sz src1 src2 dst
1586 pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg SLIT("gdiv") sz src1 src2 dst
1587 #endif
1588
1589 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1590
1591 -- Continue with I386-only printing bits and bobs:
1592
1593 pprDollImm :: Imm -> Doc
1594
1595 pprDollImm i = ptext SLIT("$") <> pprImm i
1596
1597 pprOperand :: MachRep -> Operand -> Doc
1598 pprOperand s (OpReg r) = pprReg s r
1599 pprOperand s (OpImm i) = pprDollImm i
1600 pprOperand s (OpAddr ea) = pprAddr ea
1601
1602 pprMnemonic_ :: LitString -> Doc
1603 pprMnemonic_ name =
1604 char '\t' <> ptext name <> space
1605
1606 pprMnemonic :: LitString -> MachRep -> Doc
1607 pprMnemonic name size =
1608 char '\t' <> ptext name <> pprSize size <> space
1609
1610 pprSizeImmOp :: LitString -> MachRep -> Imm -> Operand -> Doc
1611 pprSizeImmOp name size imm op1
1612 = hcat [
1613 pprMnemonic name size,
1614 char '$',
1615 pprImm imm,
1616 comma,
1617 pprOperand size op1
1618 ]
1619
1620 pprSizeOp :: LitString -> MachRep -> Operand -> Doc
1621 pprSizeOp name size op1
1622 = hcat [
1623 pprMnemonic name size,
1624 pprOperand size op1
1625 ]
1626
1627 pprSizeOpOp :: LitString -> MachRep -> Operand -> Operand -> Doc
1628 pprSizeOpOp name size op1 op2
1629 = hcat [
1630 pprMnemonic name size,
1631 pprOperand size op1,
1632 comma,
1633 pprOperand size op2
1634 ]
1635
1636 pprOpOp :: LitString -> MachRep -> Operand -> Operand -> Doc
1637 pprOpOp name size op1 op2
1638 = hcat [
1639 pprMnemonic_ name,
1640 pprOperand size op1,
1641 comma,
1642 pprOperand size op2
1643 ]
1644
1645 pprSizeReg :: LitString -> MachRep -> Reg -> Doc
1646 pprSizeReg name size reg1
1647 = hcat [
1648 pprMnemonic name size,
1649 pprReg size reg1
1650 ]
1651
1652 pprSizeRegReg :: LitString -> MachRep -> Reg -> Reg -> Doc
1653 pprSizeRegReg name size reg1 reg2
1654 = hcat [
1655 pprMnemonic name size,
1656 pprReg size reg1,
1657 comma,
1658 pprReg size reg2
1659 ]
1660
1661 pprRegReg :: LitString -> Reg -> Reg -> Doc
1662 pprRegReg name reg1 reg2
1663 = hcat [
1664 pprMnemonic_ name,
1665 pprReg wordRep reg1,
1666 comma,
1667 pprReg wordRep reg2
1668 ]
1669
1670 pprOpReg :: LitString -> Operand -> Reg -> Doc
1671 pprOpReg name op1 reg2
1672 = hcat [
1673 pprMnemonic_ name,
1674 pprOperand wordRep op1,
1675 comma,
1676 pprReg wordRep reg2
1677 ]
1678
1679 pprCondRegReg :: LitString -> MachRep -> Cond -> Reg -> Reg -> Doc
1680 pprCondRegReg name size cond reg1 reg2
1681 = hcat [
1682 char '\t',
1683 ptext name,
1684 pprCond cond,
1685 space,
1686 pprReg size reg1,
1687 comma,
1688 pprReg size reg2
1689 ]
1690
1691 pprSizeSizeRegReg :: LitString -> MachRep -> MachRep -> Reg -> Reg -> Doc
1692 pprSizeSizeRegReg name size1 size2 reg1 reg2
1693 = hcat [
1694 char '\t',
1695 ptext name,
1696 pprSize size1,
1697 pprSize size2,
1698 space,
1699 pprReg size1 reg1,
1700
1701 comma,
1702 pprReg size2 reg2
1703 ]
1704
1705 pprSizeRegRegReg :: LitString -> MachRep -> Reg -> Reg -> Reg -> Doc
1706 pprSizeRegRegReg name size reg1 reg2 reg3
1707 = hcat [
1708 pprMnemonic name size,
1709 pprReg size reg1,
1710 comma,
1711 pprReg size reg2,
1712 comma,
1713 pprReg size reg3
1714 ]
1715
1716 pprSizeAddrReg :: LitString -> MachRep -> AddrMode -> Reg -> Doc
1717 pprSizeAddrReg name size op dst
1718 = hcat [
1719 pprMnemonic name size,
1720 pprAddr op,
1721 comma,
1722 pprReg size dst
1723 ]
1724
1725 pprSizeRegAddr :: LitString -> MachRep -> Reg -> AddrMode -> Doc
1726 pprSizeRegAddr name size src op
1727 = hcat [
1728 pprMnemonic name size,
1729 pprReg size src,
1730 comma,
1731 pprAddr op
1732 ]
1733
1734 pprShift :: LitString -> MachRep -> Operand -> Operand -> Doc
1735 pprShift name size src dest
1736 = hcat [
1737 pprMnemonic name size,
1738 pprOperand I8 src, -- src is 8-bit sized
1739 comma,
1740 pprOperand size dest
1741 ]
1742
1743 pprSizeOpOpCoerce :: LitString -> MachRep -> MachRep -> Operand -> Operand -> Doc
1744 pprSizeOpOpCoerce name size1 size2 op1 op2
1745 = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
1746 pprOperand size1 op1,
1747 comma,
1748 pprOperand size2 op2
1749 ]
1750
1751 pprCondInstr :: LitString -> Cond -> Doc -> Doc
1752 pprCondInstr name cond arg
1753 = hcat [ char '\t', ptext name, pprCond cond, space, arg]
1754
1755 #endif /* i386_TARGET_ARCH */
1756
1757
1758 -- ------------------------------------------------------------------------------- pprInstr for a SPARC
1759
1760 #if sparc_TARGET_ARCH
1761
1762 -- a clumsy hack for now, to handle possible double alignment problems
1763
1764 -- even clumsier, to allow for RegReg regs that show when doing indexed
1765 -- reads (bytearrays).
1766 --
1767
1768 -- Translate to the following:
1769 -- add g1,g2,g1
1770 -- ld [g1],%fn
1771 -- ld [g1+4],%f(n+1)
1772 -- sub g1,g2,g1 -- to restore g1
1773
1774 pprInstr (LD F64 (AddrRegReg g1 g2) reg)
1775 = vcat [
1776 hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1777 hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg],
1778 hcat [pp_ld_lbracket, pprReg g1, ptext SLIT("+4]"), comma, pprReg (fPair reg)],
1779 hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1780 ]
1781
1782 -- Translate to
1783 -- ld [addr],%fn
1784 -- ld [addr+4],%f(n+1)
1785 pprInstr (LD F64 addr reg) | isJust off_addr
1786 = vcat [
1787 hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
1788 hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg (fPair reg)]
1789 ]
1790 where
1791 off_addr = addrOffset addr 4
1792 addr2 = case off_addr of Just x -> x
1793
1794
1795 pprInstr (LD size addr reg)
1796 = hcat [
1797 ptext SLIT("\tld"),
1798 pprSize size,
1799 char '\t',
1800 lbrack,
1801 pprAddr addr,
1802 pp_rbracket_comma,
1803 pprReg reg
1804 ]
1805
1806 -- The same clumsy hack as above
1807
1808 -- Translate to the following:
1809 -- add g1,g2,g1
1810 -- st %fn,[g1]
1811 -- st %f(n+1),[g1+4]
1812 -- sub g1,g2,g1 -- to restore g1
1813 pprInstr (ST F64 reg (AddrRegReg g1 g2))
1814 = vcat [
1815 hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1816 hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1817 pprReg g1, rbrack],
1818 hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1819 pprReg g1, ptext SLIT("+4]")],
1820 hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1821 ]
1822
1823 -- Translate to
1824 -- st %fn,[addr]
1825 -- st %f(n+1),[addr+4]
1826 pprInstr (ST F64 reg addr) | isJust off_addr
1827 = vcat [
1828 hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1829 pprAddr addr, rbrack],
1830 hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1831 pprAddr addr2, rbrack]
1832 ]
1833 where
1834 off_addr = addrOffset addr 4
1835 addr2 = case off_addr of Just x -> x
1836
1837 -- no distinction is made between signed and unsigned bytes on stores for the
1838 -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
1839 -- so we call a special-purpose pprSize for ST..
1840
1841 pprInstr (ST size reg addr)
1842 = hcat [
1843 ptext SLIT("\tst"),
1844 pprStSize size,
1845 char '\t',
1846 pprReg reg,
1847 pp_comma_lbracket,
1848 pprAddr addr,
1849 rbrack
1850 ]
1851
1852 pprInstr (ADD x cc reg1 ri reg2)
1853 | not x && not cc && riZero ri
1854 = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1855 | otherwise
1856 = pprRegRIReg (if x then SLIT("addx") else SLIT("add")) cc reg1 ri reg2
1857
1858 pprInstr (SUB x cc reg1 ri reg2)
1859 | not x && cc && reg2 == g0
1860 = hcat [ ptext SLIT("\tcmp\t"), pprReg reg1, comma, pprRI ri ]
1861 | not x && not cc && riZero ri
1862 = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1863 | otherwise
1864 = pprRegRIReg (if x then SLIT("subx") else SLIT("sub")) cc reg1 ri reg2
1865
1866 pprInstr (AND b reg1 ri reg2) = pprRegRIReg SLIT("and") b reg1 ri reg2
1867 pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg SLIT("andn") b reg1 ri reg2
1868
1869 pprInstr (OR b reg1 ri reg2)
1870 | not b && reg1 == g0
1871 = let doit = hcat [ ptext SLIT("\tmov\t"), pprRI ri, comma, pprReg reg2 ]
1872 in case ri of
1873 RIReg rrr | rrr == reg2 -> empty
1874 other -> doit
1875 | otherwise
1876 = pprRegRIReg SLIT("or") b reg1 ri reg2
1877
1878 pprInstr (ORN b reg1 ri reg2) = pprRegRIReg SLIT("orn") b reg1 ri reg2
1879
1880 pprInstr (XOR b reg1 ri reg2) = pprRegRIReg SLIT("xor") b reg1 ri reg2
1881 pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg SLIT("xnor") b reg1 ri reg2
1882
1883 pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") False reg1 ri reg2
1884 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") False reg1 ri reg2
1885 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") False reg1 ri reg2
1886
1887 pprInstr (RDY rd) = ptext SLIT("\trd\t%y,") <> pprReg rd
1888 pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg SLIT("smul") b reg1 ri reg2
1889 pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg SLIT("umul") b reg1 ri reg2
1890
1891 pprInstr (SETHI imm reg)
1892 = hcat [
1893 ptext SLIT("\tsethi\t"),
1894 pprImm imm,
1895 comma,
1896 pprReg reg
1897 ]
1898
1899 pprInstr NOP = ptext SLIT("\tnop")
1900
1901 pprInstr (FABS F32 reg1 reg2) = pprSizeRegReg SLIT("fabs") F32 reg1 reg2
1902 pprInstr (FABS F64 reg1 reg2)
1903 = (<>) (pprSizeRegReg SLIT("fabs") F32 reg1 reg2)
1904 (if (reg1 == reg2) then empty
1905 else (<>) (char '\n')
1906 (pprSizeRegReg SLIT("fmov") F32 (fPair reg1) (fPair reg2)))
1907
1908 pprInstr (FADD size reg1 reg2 reg3)
1909 = pprSizeRegRegReg SLIT("fadd") size reg1 reg2 reg3
1910 pprInstr (FCMP e size reg1 reg2)
1911 = pprSizeRegReg (if e then SLIT("fcmpe") else SLIT("fcmp")) size reg1 reg2
1912 pprInstr (FDIV size reg1 reg2 reg3)
1913 = pprSizeRegRegReg SLIT("fdiv") size reg1 reg2 reg3
1914
1915 pprInstr (FMOV F32 reg1 reg2) = pprSizeRegReg SLIT("fmov") F32 reg1 reg2
1916 pprInstr (FMOV F64 reg1 reg2)
1917 = (<>) (pprSizeRegReg SLIT("fmov") F32 reg1 reg2)
1918 (if (reg1 == reg2) then empty
1919 else (<>) (char '\n')
1920 (pprSizeRegReg SLIT("fmov") F32 (fPair reg1) (fPair reg2)))
1921
1922 pprInstr (FMUL size reg1 reg2 reg3)
1923 = pprSizeRegRegReg SLIT("fmul") size reg1 reg2 reg3
1924
1925 pprInstr (FNEG F32 reg1 reg2) = pprSizeRegReg SLIT("fneg") F32 reg1 reg2
1926 pprInstr (FNEG F64 reg1 reg2)
1927 = (<>) (pprSizeRegReg SLIT("fneg") F32 reg1 reg2)
1928 (if (reg1 == reg2) then empty
1929 else (<>) (char '\n')
1930 (pprSizeRegReg SLIT("fmov") F32 (fPair reg1) (fPair reg2)))
1931
1932 pprInstr (FSQRT size reg1 reg2) = pprSizeRegReg SLIT("fsqrt") size reg1 reg2
1933 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fsub") size reg1 reg2 reg3
1934 pprInstr (FxTOy size1 size2 reg1 reg2)
1935 = hcat [
1936 ptext SLIT("\tf"),
1937 ptext
1938 (case size1 of
1939 I32 -> SLIT("ito")
1940 F32 -> SLIT("sto")
1941 F64 -> SLIT("dto")),
1942 ptext
1943 (case size2 of
1944 I32 -> SLIT("i\t")
1945 F32 -> SLIT("s\t")
1946 F64 -> SLIT("d\t")),
1947 pprReg reg1, comma, pprReg reg2
1948 ]
1949
1950
1951 pprInstr (BI cond b lab)
1952 = hcat [
1953 ptext SLIT("\tb"), pprCond cond,
1954 if b then pp_comma_a else empty,
1955 char '\t',
1956 pprImm lab
1957 ]
1958
1959 pprInstr (BF cond b lab)
1960 = hcat [
1961 ptext SLIT("\tfb"), pprCond cond,
1962 if b then pp_comma_a else empty,
1963 char '\t',
1964 pprImm lab
1965 ]
1966
1967 pprInstr (JMP addr) = (<>) (ptext SLIT("\tjmp\t")) (pprAddr addr)
1968
1969 pprInstr (CALL (Left imm) n _)
1970 = hcat [ ptext SLIT("\tcall\t"), pprImm imm, comma, int n ]
1971 pprInstr (CALL (Right reg) n _)
1972 = hcat [ ptext SLIT("\tcall\t"), pprReg reg, comma, int n ]
1973
1974 pprRI :: RI -> Doc
1975 pprRI (RIReg r) = pprReg r
1976 pprRI (RIImm r) = pprImm r
1977
1978 pprSizeRegReg :: LitString -> MachRep -> Reg -> Reg -> Doc
1979 pprSizeRegReg name size reg1 reg2
1980 = hcat [
1981 char '\t',
1982 ptext name,
1983 (case size of
1984 F32 -> ptext SLIT("s\t")
1985 F64 -> ptext SLIT("d\t")),
1986 pprReg reg1,
1987 comma,
1988 pprReg reg2
1989 ]
1990
1991 pprSizeRegRegReg :: LitString -> MachRep -> Reg -> Reg -> Reg -> Doc
1992 pprSizeRegRegReg name size reg1 reg2 reg3
1993 = hcat [
1994 char '\t',
1995 ptext name,
1996 (case size of
1997 F32 -> ptext SLIT("s\t")
1998 F64 -> ptext SLIT("d\t")),
1999 pprReg reg1,
2000 comma,
2001 pprReg reg2,
2002 comma,
2003 pprReg reg3
2004 ]
2005
2006 pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
2007 pprRegRIReg name b reg1 ri reg2
2008 = hcat [
2009 char '\t',
2010 ptext name,
2011 if b then ptext SLIT("cc\t") else char '\t',
2012 pprReg reg1,
2013 comma,
2014 pprRI ri,
2015 comma,
2016 pprReg reg2
2017 ]
2018
2019 pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
2020 pprRIReg name b ri reg1
2021 = hcat [
2022 char '\t',
2023 ptext name,
2024 if b then ptext SLIT("cc\t") else char '\t',
2025 pprRI ri,
2026 comma,
2027 pprReg reg1
2028 ]
2029
2030 pp_ld_lbracket = ptext SLIT("\tld\t[")
2031 pp_rbracket_comma = text "],"
2032 pp_comma_lbracket = text ",["
2033 pp_comma_a = text ",a"
2034
2035 #endif /* sparc_TARGET_ARCH */
2036
2037
2038 -- -----------------------------------------------------------------------------
2039 -- pprInstr for PowerPC
2040
2041 #if powerpc_TARGET_ARCH
2042 pprInstr (LD sz reg addr) = hcat [
2043 char '\t',
2044 ptext SLIT("l"),
2045 ptext (case sz of
2046 I8 -> SLIT("bz")
2047 I16 -> SLIT("hz")
2048 I32 -> SLIT("wz")
2049 F32 -> SLIT("fs")
2050 F64 -> SLIT("fd")),
2051 case addr of AddrRegImm _ _ -> empty
2052 AddrRegReg _ _ -> char 'x',
2053 char '\t',
2054 pprReg reg,
2055 ptext SLIT(", "),
2056 pprAddr addr
2057 ]
2058 pprInstr (LA sz reg addr) = hcat [
2059 char '\t',
2060 ptext SLIT("l"),
2061 ptext (case sz of
2062 I8 -> SLIT("ba")
2063 I16 -> SLIT("ha")
2064 I32 -> SLIT("wa")
2065 F32 -> SLIT("fs")
2066 F64 -> SLIT("fd")),
2067 case addr of AddrRegImm _ _ -> empty
2068 AddrRegReg _ _ -> char 'x',
2069 char '\t',
2070 pprReg reg,
2071 ptext SLIT(", "),
2072 pprAddr addr
2073 ]
2074 pprInstr (ST sz reg addr) = hcat [
2075 char '\t',
2076 ptext SLIT("st"),
2077 pprSize sz,
2078 case addr of AddrRegImm _ _ -> empty
2079 AddrRegReg _ _ -> char 'x',
2080 char '\t',
2081 pprReg reg,
2082 ptext SLIT(", "),
2083 pprAddr addr
2084 ]
2085 pprInstr (STU sz reg addr) = hcat [
2086 char '\t',
2087 ptext SLIT("st"),
2088 pprSize sz,
2089 ptext SLIT("u\t"),
2090 case addr of AddrRegImm _ _ -> empty
2091 AddrRegReg _ _ -> char 'x',
2092 pprReg reg,
2093 ptext SLIT(", "),
2094 pprAddr addr
2095 ]
2096 pprInstr (LIS reg imm) = hcat [
2097 char '\t',
2098 ptext SLIT("lis"),
2099 char '\t',
2100 pprReg reg,
2101 ptext SLIT(", "),
2102 pprImm imm
2103 ]
2104 pprInstr (LI reg imm) = hcat [
2105 char '\t',
2106 ptext SLIT("li"),
2107 char '\t',
2108 pprReg reg,
2109 ptext SLIT(", "),
2110 pprImm imm
2111 ]
2112 pprInstr (MR reg1 reg2)
2113 | reg1 == reg2 = empty
2114 | otherwise = hcat [
2115 char '\t',
2116 case regClass reg1 of
2117 RcInteger -> ptext SLIT("mr")
2118 _ -> ptext SLIT("fmr"),
2119 char '\t',
2120 pprReg reg1,
2121 ptext SLIT(", "),
2122 pprReg reg2
2123 ]
2124 pprInstr (CMP sz reg ri) = hcat [
2125 char '\t',
2126 op,
2127 char '\t',
2128 pprReg reg,
2129 ptext SLIT(", "),
2130 pprRI ri
2131 ]
2132 where
2133 op = hcat [
2134 ptext SLIT("cmp"),
2135 pprSize sz,
2136 case ri of
2137 RIReg _ -> empty
2138 RIImm _ -> char 'i'
2139 ]
2140 pprInstr (CMPL sz reg ri) = hcat [
2141 char '\t',
2142 op,
2143 char '\t',
2144 pprReg reg,
2145 ptext SLIT(", "),
2146 pprRI ri
2147 ]
2148 where
2149 op = hcat [
2150 ptext SLIT("cmpl"),
2151 pprSize sz,
2152 case ri of
2153 RIReg _ -> empty
2154 RIImm _ -> char 'i'
2155 ]
2156 pprInstr (BCC cond (BlockId id)) = hcat [
2157 char '\t',
2158 ptext SLIT("b"),
2159 pprCond cond,
2160 char '\t',
2161 pprCLabel_asm lbl
2162 ]
2163 where lbl = mkAsmTempLabel id
2164
2165 pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
2166 char '\t',
2167 ptext SLIT("b"),
2168 char '\t',
2169 pprCLabel_asm lbl
2170 ]
2171
2172 pprInstr (MTCTR reg) = hcat [
2173 char '\t',
2174 ptext SLIT("mtctr"),
2175 char '\t',
2176 pprReg reg
2177 ]
2178 pprInstr (BCTR _) = hcat [
2179 char '\t',
2180 ptext SLIT("bctr")
2181 ]
2182 pprInstr (BL lbl _) = hcat [
2183 ptext SLIT("\tbl\t"),
2184 pprCLabel_asm lbl
2185 ]
2186 pprInstr (BCTRL _) = hcat [
2187 char '\t',
2188 ptext SLIT("bctrl")
2189 ]
2190 pprInstr (ADD reg1 reg2 ri) = pprLogic SLIT("add") reg1 reg2 ri
2191 pprInstr (ADDIS reg1 reg2 imm) = hcat [
2192 char '\t',
2193 ptext SLIT("addis"),
2194 char '\t',
2195 pprReg reg1,
2196 ptext SLIT(", "),
2197 pprReg reg2,
2198 ptext SLIT(", "),
2199 pprImm imm
2200 ]
2201
2202 pprInstr (ADDC reg1 reg2 reg3) = pprLogic SLIT("addc") reg1 reg2 (RIReg reg3)
2203 pprInstr (ADDE reg1 reg2 reg3) = pprLogic SLIT("adde") reg1 reg2 (RIReg reg3)
2204 pprInstr (SUBF reg1 reg2 reg3) = pprLogic SLIT("subf") reg1 reg2 (RIReg reg3)
2205 pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic SLIT("mullw") reg1 reg2 ri
2206 pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic SLIT("mull") reg1 reg2 ri
2207 pprInstr (DIVW reg1 reg2 reg3) = pprLogic SLIT("divw") reg1 reg2 (RIReg reg3)
2208 pprInstr (DIVWU reg1 reg2 reg3) = pprLogic SLIT("divwu") reg1 reg2 (RIReg reg3)
2209
2210 pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
2211 hcat [ ptext SLIT("\tmullwo\t"), pprReg reg1, ptext SLIT(", "),
2212 pprReg reg2, ptext SLIT(", "),
2213 pprReg reg3 ],
2214 hcat [ ptext SLIT("\tmfxer\t"), pprReg reg1 ],
2215 hcat [ ptext SLIT("\trlwinm\t"), pprReg reg1, ptext SLIT(", "),
2216 pprReg reg1, ptext SLIT(", "),
2217 ptext SLIT("2, 31, 31") ]
2218 ]
2219
2220 -- for some reason, "andi" doesn't exist.
2221 -- we'll use "andi." instead.
2222 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
2223 char '\t',
2224 ptext SLIT("andi."),
2225 char '\t',
2226 pprReg reg1,
2227 ptext SLIT(", "),
2228 pprReg reg2,
2229 ptext SLIT(", "),
2230 pprImm imm
2231 ]
2232 pprInstr (AND reg1 reg2 ri) = pprLogic SLIT("and") reg1 reg2 ri
2233
2234 pprInstr (OR reg1 reg2 ri) = pprLogic SLIT("or") reg1 reg2 ri
2235 pprInstr (XOR reg1 reg2 ri) = pprLogic SLIT("xor") reg1 reg2 ri
2236
2237 pprInstr (XORIS reg1 reg2 imm) = hcat [
2238 char '\t',
2239 ptext SLIT("xoris"),
2240 char '\t',
2241 pprReg reg1,
2242 ptext SLIT(", "),
2243 pprReg reg2,
2244 ptext SLIT(", "),
2245 pprImm imm
2246 ]
2247
2248 pprInstr (EXTS sz reg1 reg2) = hcat [
2249 char '\t',
2250 ptext SLIT("exts"),
2251 pprSize sz,
2252 char '\t',
2253 pprReg reg1,
2254 ptext SLIT(", "),
2255 pprReg reg2
2256 ]
2257
2258 pprInstr (NEG reg1 reg2) = pprUnary SLIT("neg") reg1 reg2
2259 pprInstr (NOT reg1 reg2) = pprUnary SLIT("not") reg1 reg2
2260
2261 pprInstr (SLW reg1 reg2 ri) = pprLogic SLIT("slw") reg1 reg2 (limitShiftRI ri)
2262 pprInstr (SRW reg1 reg2 ri) = pprLogic SLIT("srw") reg1 reg2 (limitShiftRI ri)
2263 pprInstr (SRAW reg1 reg2 ri) = pprLogic SLIT("sraw") reg1 reg2 (limitShiftRI ri)
2264 pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
2265 ptext SLIT("\trlwinm\t"),
2266 pprReg reg1,
2267 ptext SLIT(", "),
2268 pprReg reg2,
2269 ptext SLIT(", "),
2270 int sh,
2271 ptext SLIT(", "),
2272 int mb,
2273 ptext SLIT(", "),
2274 int me
2275 ]
2276
2277 pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF SLIT("fadd") sz reg1 reg2 reg3
2278 pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF SLIT("fsub") sz reg1 reg2 reg3
2279 pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF SLIT("fmul") sz reg1 reg2 reg3
2280 pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF SLIT("fdiv") sz reg1 reg2 reg3
2281 pprInstr (FNEG reg1 reg2) = pprUnary SLIT("fneg") reg1 reg2
2282
2283 pprInstr (FCMP reg1 reg2) = hcat [
2284 char '\t',
2285 ptext SLIT("fcmpu\tcr0, "),
2286 -- Note: we're using fcmpu, not fcmpo
2287 -- The difference is with fcmpo, compare with NaN is an invalid operation.
2288 -- We don't handle invalid fp ops, so we don't care
2289 pprReg reg1,
2290 ptext SLIT(", "),
2291 pprReg reg2
2292 ]
2293
2294 pprInstr (FCTIWZ reg1 reg2) = pprUnary SLIT("fctiwz") reg1 reg2
2295 pprInstr (FRSP reg1 reg2) = pprUnary SLIT("frsp") reg1 reg2
2296
2297 pprInstr (CRNOR dst src1 src2) = hcat [
2298 ptext SLIT("\tcrnor\t"),
2299 int dst,
2300 ptext SLIT(", "),
2301 int src1,
2302 ptext SLIT(", "),
2303 int src2
2304 ]
2305
2306 pprInstr (MFCR reg) = hcat [
2307 char '\t',
2308 ptext SLIT("mfcr"),
2309 char '\t',
2310 pprReg reg
2311 ]
2312
2313 pprInstr (MFLR reg) = hcat [
2314 char '\t',
2315 ptext SLIT("mflr"),
2316 char '\t',
2317 pprReg reg
2318 ]
2319
2320 pprInstr (FETCHPC reg) = vcat [
2321 ptext SLIT("\tbcl\t20,31,1f"),
2322 hcat [ ptext SLIT("1:\tmflr\t"), pprReg reg ]
2323 ]
2324
2325 pprInstr LWSYNC = ptext SLIT("\tlwsync")
2326
2327 pprInstr _ = panic "pprInstr (ppc)"
2328
2329 pprLogic op reg1 reg2 ri = hcat [
2330 char '\t',
2331 ptext op,
2332 case ri of
2333 RIReg _ -> empty
2334 RIImm _ -> char 'i',
2335 char '\t',
2336 pprReg reg1,
2337 ptext SLIT(", "),
2338 pprReg reg2,
2339 ptext SLIT(", "),
2340 pprRI ri
2341 ]
2342
2343 pprUnary op reg1 reg2 = hcat [
2344 char '\t',
2345 ptext op,
2346 char '\t',
2347 pprReg reg1,
2348 ptext SLIT(", "),
2349 pprReg reg2
2350 ]
2351
2352 pprBinaryF op sz reg1 reg2 reg3 = hcat [
2353 char '\t',
2354 ptext op,
2355 pprFSize sz,
2356 char '\t',
2357 pprReg reg1,
2358 ptext SLIT(", "),
2359 pprReg reg2,
2360 ptext SLIT(", "),
2361 pprReg reg3
2362 ]
2363
2364 pprRI :: RI -> Doc
2365 pprRI (RIReg r) = pprReg r
2366 pprRI (RIImm r) = pprImm r
2367
2368 pprFSize F64 = empty
2369 pprFSize F32 = char 's'
2370
2371 -- limit immediate argument for shift instruction to range 0..32
2372 -- (yes, the maximum is really 32, not 31)
2373 limitShiftRI :: RI -> RI
2374 limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32)
2375 limitShiftRI x = x
2376
2377 #endif /* powerpc_TARGET_ARCH */
2378
2379
2380 -- -----------------------------------------------------------------------------
2381 -- Converting floating-point literals to integrals for printing
2382
2383 #if __GLASGOW_HASKELL__ >= 504
2384 newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
2385 newFloatArray = newArray_
2386
2387 newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
2388 newDoubleArray = newArray_
2389
2390 castFloatToCharArray :: STUArray s Int Float -> ST s (STUArray s Int Word8)
2391 castFloatToCharArray = castSTUArray
2392
2393 castDoubleToCharArray :: STUArray s Int Double -> ST s (STUArray s Int Word8)
2394 castDoubleToCharArray = castSTUArray
2395
2396 writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
2397 writeFloatArray = writeArray
2398
2399 writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
2400 writeDoubleArray = writeArray
2401
2402 readCharArray :: STUArray s Int Word8 -> Int -> ST s Char
2403 readCharArray arr i = do
2404 w <- readArray arr i
2405 return $! (chr (fromIntegral w))
2406
2407 #else
2408
2409 castFloatToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2410 castFloatToCharArray = return
2411
2412 castDoubleToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2413
2414
2415 castDoubleToCharArray = return
2416
2417 #endif
2418
2419 -- floatToBytes and doubleToBytes convert to the host's byte
2420 -- order. Providing that we're not cross-compiling for a
2421 -- target with the opposite endianness, this should work ok
2422 -- on all targets.
2423
2424 -- ToDo: this stuff is very similar to the shenanigans in PprAbs,
2425 -- could they be merged?
2426
2427 floatToBytes :: Float -> [Int]
2428 floatToBytes f
2429 = runST (do
2430 arr <- newFloatArray ((0::Int),3)
2431 writeFloatArray arr 0 f
2432 arr <- castFloatToCharArray arr
2433 i0 <- readCharArray arr 0
2434 i1 <- readCharArray arr 1
2435 i2 <- readCharArray arr 2
2436 i3 <- readCharArray arr 3
2437 return (map ord [i0,i1,i2,i3])
2438 )
2439
2440 doubleToBytes :: Double -> [Int]
2441 doubleToBytes d
2442 = runST (do
2443 arr <- newDoubleArray ((0::Int),7)
2444 writeDoubleArray arr 0 d
2445 arr <- castDoubleToCharArray arr
2446 i0 <- readCharArray arr 0
2447 i1 <- readCharArray arr 1
2448 i2 <- readCharArray arr 2
2449 i3 <- readCharArray arr 3
2450 i4 <- readCharArray arr 4
2451 i5 <- readCharArray arr 5
2452 i6 <- readCharArray arr 6
2453 i7 <- readCharArray arr 7
2454 return (map ord [i0,i1,i2,i3,i4,i5,i6,i7])
2455 )