1 -----------------------------------------------------------------------------
3 -- Pretty-printing assembly language
5 -- (c) The University of Glasgow 1993-2005
7 -----------------------------------------------------------------------------
9 -- We start with the @pprXXX@s with some cross-platform commonality
10 -- (e.g., 'pprReg'); we conclude with the no-commonality monster,
13 #include "nativeGen/NCG.h"
16 pprNatCmmTop, pprBasicBlock,
17 pprInstr, pprSize, pprUserReg,
21 #include "HsVersions.h"
24 import MachOp ( MachRep(..), wordRep, isFloatingRep )
25 import MachRegs -- may differ per-platform
28 import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel,
29 labelDynamic, mkAsmTempLabel, entryLblToInfoLbl )
30 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
31 import CLabel ( mkDeadStripPreventer )
34 import Panic ( panic )
35 import Unique ( pprUnique )
38 import qualified Outputable
40 import StaticFlags ( opt_PIC, opt_Static )
42 #if __GLASGOW_HASKELL__ >= 504
44 import Data.Word ( Word8 )
50 import Char ( chr, ord )
51 import Maybe ( isJust )
53 #if powerpc_TARGET_ARCH
54 import DATA_WORD(Word32)
58 -- -----------------------------------------------------------------------------
59 -- Printing this stuff out
61 asmSDoc d = Outputable.withPprStyleDoc (
62 Outputable.mkCodeStyle Outputable.AsmStyle) d
63 pprCLabel_asm l = asmSDoc (pprCLabel l)
65 pprNatCmmTop :: NatCmmTop -> Doc
66 pprNatCmmTop (CmmData section dats) =
67 pprSectionHeader section $$ vcat (map pprData dats)
69 -- special case for split markers:
70 pprNatCmmTop (CmmProc [] lbl _ []) = pprLabel lbl
72 pprNatCmmTop (CmmProc info lbl params blocks) =
73 pprSectionHeader Text $$
76 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
77 pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
80 vcat (map pprData info) $$
81 pprLabel (entryLblToInfoLbl lbl)
85 (BasicBlock _ instrs : rest) ->
86 (if null info then pprLabel lbl else empty) $$
87 -- the first block doesn't get a label:
88 vcat (map pprInstr instrs) $$
89 vcat (map pprBasicBlock rest)
91 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
92 -- If we are using the .subsections_via_symbols directive
93 -- (available on recent versions of Darwin),
94 -- we have to make sure that there is some kind of reference
95 -- from the entry code to a label on the _top_ of of the info table,
96 -- so that the linker will not think it is unreferenced and dead-strip
97 -- it. That's why the label is called a DeadStripPreventer (_dsp).
100 <+> pprCLabel_asm (entryLblToInfoLbl lbl)
102 <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
107 pprBasicBlock :: NatBasicBlock -> Doc
108 pprBasicBlock (BasicBlock (BlockId id) instrs) =
109 pprLabel (mkAsmTempLabel id) $$
110 vcat (map pprInstr instrs)
112 -- -----------------------------------------------------------------------------
113 -- pprReg: print a 'Reg'
115 -- For x86, the way we print a register name depends
116 -- on which bit of it we care about. Yurgh.
118 pprUserReg :: Reg -> Doc
119 pprUserReg = pprReg IF_ARCH_i386(I32,) IF_ARCH_x86_64(I64,)
121 pprReg :: IF_ARCH_i386(MachRep ->,) IF_ARCH_x86_64(MachRep ->,) Reg -> Doc
123 pprReg IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) r
125 RealReg i -> ppr_reg_no IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) i
126 VirtualRegI u -> text "%vI_" <> asmSDoc (pprUnique u)
127 VirtualRegHi u -> text "%vHi_" <> asmSDoc (pprUnique u)
128 VirtualRegF u -> text "%vF_" <> asmSDoc (pprUnique u)
129 VirtualRegD u -> text "%vD_" <> asmSDoc (pprUnique u)
131 #if alpha_TARGET_ARCH
132 ppr_reg_no :: Int -> Doc
135 0 -> SLIT("$0"); 1 -> SLIT("$1");
136 2 -> SLIT("$2"); 3 -> SLIT("$3");
137 4 -> SLIT("$4"); 5 -> SLIT("$5");
138 6 -> SLIT("$6"); 7 -> SLIT("$7");
139 8 -> SLIT("$8"); 9 -> SLIT("$9");
140 10 -> SLIT("$10"); 11 -> SLIT("$11");
141 12 -> SLIT("$12"); 13 -> SLIT("$13");
142 14 -> SLIT("$14"); 15 -> SLIT("$15");
143 16 -> SLIT("$16"); 17 -> SLIT("$17");
144 18 -> SLIT("$18"); 19 -> SLIT("$19");
145 20 -> SLIT("$20"); 21 -> SLIT("$21");
146 22 -> SLIT("$22"); 23 -> SLIT("$23");
147 24 -> SLIT("$24"); 25 -> SLIT("$25");
148 26 -> SLIT("$26"); 27 -> SLIT("$27");
149 28 -> SLIT("$28"); 29 -> SLIT("$29");
150 30 -> SLIT("$30"); 31 -> SLIT("$31");
151 32 -> SLIT("$f0"); 33 -> SLIT("$f1");
152 34 -> SLIT("$f2"); 35 -> SLIT("$f3");
153 36 -> SLIT("$f4"); 37 -> SLIT("$f5");
154 38 -> SLIT("$f6"); 39 -> SLIT("$f7");
155 40 -> SLIT("$f8"); 41 -> SLIT("$f9");
156 42 -> SLIT("$f10"); 43 -> SLIT("$f11");
157 44 -> SLIT("$f12"); 45 -> SLIT("$f13");
158 46 -> SLIT("$f14"); 47 -> SLIT("$f15");
159 48 -> SLIT("$f16"); 49 -> SLIT("$f17");
160 50 -> SLIT("$f18"); 51 -> SLIT("$f19");
161 52 -> SLIT("$f20"); 53 -> SLIT("$f21");
162 54 -> SLIT("$f22"); 55 -> SLIT("$f23");
163 56 -> SLIT("$f24"); 57 -> SLIT("$f25");
164 58 -> SLIT("$f26"); 59 -> SLIT("$f27");
165 60 -> SLIT("$f28"); 61 -> SLIT("$f29");
166 62 -> SLIT("$f30"); 63 -> SLIT("$f31");
167 _ -> SLIT("very naughty alpha register")
171 ppr_reg_no :: MachRep -> Int -> Doc
172 ppr_reg_no I8 = ppr_reg_byte
173 ppr_reg_no I16 = ppr_reg_word
174 ppr_reg_no _ = ppr_reg_long
176 ppr_reg_byte i = ptext
178 0 -> SLIT("%al"); 1 -> SLIT("%bl");
179 2 -> SLIT("%cl"); 3 -> SLIT("%dl");
180 _ -> SLIT("very naughty I386 byte register")
183 ppr_reg_word i = ptext
185 0 -> SLIT("%ax"); 1 -> SLIT("%bx");
186 2 -> SLIT("%cx"); 3 -> SLIT("%dx");
187 4 -> SLIT("%si"); 5 -> SLIT("%di");
188 6 -> SLIT("%bp"); 7 -> SLIT("%sp");
189 _ -> SLIT("very naughty I386 word register")
192 ppr_reg_long i = ptext
194 0 -> SLIT("%eax"); 1 -> SLIT("%ebx");
195 2 -> SLIT("%ecx"); 3 -> SLIT("%edx");
196 4 -> SLIT("%esi"); 5 -> SLIT("%edi");
197 6 -> SLIT("%ebp"); 7 -> SLIT("%esp");
198 8 -> SLIT("%fake0"); 9 -> SLIT("%fake1");
199 10 -> SLIT("%fake2"); 11 -> SLIT("%fake3");
200 12 -> SLIT("%fake4"); 13 -> SLIT("%fake5");
201 _ -> SLIT("very naughty I386 register")
205 #if x86_64_TARGET_ARCH
206 ppr_reg_no :: MachRep -> Int -> Doc
207 ppr_reg_no I8 = ppr_reg_byte
208 ppr_reg_no I16 = ppr_reg_word
209 ppr_reg_no I32 = ppr_reg_long
210 ppr_reg_no _ = ppr_reg_quad
212 ppr_reg_byte i = ptext
214 0 -> SLIT("%al"); 1 -> SLIT("%bl");
215 2 -> SLIT("%cl"); 3 -> SLIT("%dl");
216 4 -> SLIT("%sil"); 5 -> SLIT("%dil"); -- new 8-bit regs!
217 6 -> SLIT("%bpl"); 7 -> SLIT("%spl");
218 8 -> SLIT("%r8b"); 9 -> SLIT("%r9b");
219 10 -> SLIT("%r10b"); 11 -> SLIT("%r11b");
220 12 -> SLIT("%r12b"); 13 -> SLIT("%r13b");
221 14 -> SLIT("%r14b"); 15 -> SLIT("%r15b");
222 _ -> SLIT("very naughty x86_64 byte register")
225 ppr_reg_word i = ptext
227 0 -> SLIT("%ax"); 1 -> SLIT("%bx");
228 2 -> SLIT("%cx"); 3 -> SLIT("%dx");
229 4 -> SLIT("%si"); 5 -> SLIT("%di");
230 6 -> SLIT("%bp"); 7 -> SLIT("%sp");
231 8 -> SLIT("%r8w"); 9 -> SLIT("%r9w");
232 10 -> SLIT("%r10w"); 11 -> SLIT("%r11w");
233 12 -> SLIT("%r12w"); 13 -> SLIT("%r13w");
234 14 -> SLIT("%r14w"); 15 -> SLIT("%r15w");
235 _ -> SLIT("very naughty x86_64 word register")
238 ppr_reg_long i = ptext
240 0 -> SLIT("%eax"); 1 -> SLIT("%ebx");
241 2 -> SLIT("%ecx"); 3 -> SLIT("%edx");
242 4 -> SLIT("%esi"); 5 -> SLIT("%edi");
243 6 -> SLIT("%ebp"); 7 -> SLIT("%esp");
244 8 -> SLIT("%r8d"); 9 -> SLIT("%r9d");
245 10 -> SLIT("%r10d"); 11 -> SLIT("%r11d");
246 12 -> SLIT("%r12d"); 13 -> SLIT("%r13d");
247 14 -> SLIT("%r14d"); 15 -> SLIT("%r15d");
248 _ -> SLIT("very naughty x86_64 register")
251 ppr_reg_quad i = ptext
253 0 -> SLIT("%rax"); 1 -> SLIT("%rbx");
254 2 -> SLIT("%rcx"); 3 -> SLIT("%rdx");
255 4 -> SLIT("%rsi"); 5 -> SLIT("%rdi");
256 6 -> SLIT("%rbp"); 7 -> SLIT("%rsp");
257 8 -> SLIT("%r8"); 9 -> SLIT("%r9");
258 10 -> SLIT("%r10"); 11 -> SLIT("%r11");
259 12 -> SLIT("%r12"); 13 -> SLIT("%r13");
260 14 -> SLIT("%r14"); 15 -> SLIT("%r15");
261 16 -> SLIT("%xmm0"); 17 -> SLIT("%xmm1");
262 18 -> SLIT("%xmm2"); 19 -> SLIT("%xmm3");
263 20 -> SLIT("%xmm4"); 21 -> SLIT("%xmm5");
264 22 -> SLIT("%xmm6"); 23 -> SLIT("%xmm7");
265 24 -> SLIT("%xmm8"); 25 -> SLIT("%xmm9");
266 26 -> SLIT("%xmm10"); 27 -> SLIT("%xmm11");
267 28 -> SLIT("%xmm12"); 29 -> SLIT("%xmm13");
268 30 -> SLIT("%xmm14"); 31 -> SLIT("%xmm15");
269 _ -> SLIT("very naughty x86_64 register")
273 #if sparc_TARGET_ARCH
274 ppr_reg_no :: Int -> Doc
277 0 -> SLIT("%g0"); 1 -> SLIT("%g1");
278 2 -> SLIT("%g2"); 3 -> SLIT("%g3");
279 4 -> SLIT("%g4"); 5 -> SLIT("%g5");
280 6 -> SLIT("%g6"); 7 -> SLIT("%g7");
281 8 -> SLIT("%o0"); 9 -> SLIT("%o1");
282 10 -> SLIT("%o2"); 11 -> SLIT("%o3");
283 12 -> SLIT("%o4"); 13 -> SLIT("%o5");
284 14 -> SLIT("%o6"); 15 -> SLIT("%o7");
285 16 -> SLIT("%l0"); 17 -> SLIT("%l1");
286 18 -> SLIT("%l2"); 19 -> SLIT("%l3");
287 20 -> SLIT("%l4"); 21 -> SLIT("%l5");
288 22 -> SLIT("%l6"); 23 -> SLIT("%l7");
289 24 -> SLIT("%i0"); 25 -> SLIT("%i1");
290 26 -> SLIT("%i2"); 27 -> SLIT("%i3");
291 28 -> SLIT("%i4"); 29 -> SLIT("%i5");
292 30 -> SLIT("%i6"); 31 -> SLIT("%i7");
293 32 -> SLIT("%f0"); 33 -> SLIT("%f1");
294 34 -> SLIT("%f2"); 35 -> SLIT("%f3");
295 36 -> SLIT("%f4"); 37 -> SLIT("%f5");
296 38 -> SLIT("%f6"); 39 -> SLIT("%f7");
297 40 -> SLIT("%f8"); 41 -> SLIT("%f9");
298 42 -> SLIT("%f10"); 43 -> SLIT("%f11");
299 44 -> SLIT("%f12"); 45 -> SLIT("%f13");
300 46 -> SLIT("%f14"); 47 -> SLIT("%f15");
301 48 -> SLIT("%f16"); 49 -> SLIT("%f17");
302 50 -> SLIT("%f18"); 51 -> SLIT("%f19");
303 52 -> SLIT("%f20"); 53 -> SLIT("%f21");
304 54 -> SLIT("%f22"); 55 -> SLIT("%f23");
305 56 -> SLIT("%f24"); 57 -> SLIT("%f25");
306 58 -> SLIT("%f26"); 59 -> SLIT("%f27");
307 60 -> SLIT("%f28"); 61 -> SLIT("%f29");
308 62 -> SLIT("%f30"); 63 -> SLIT("%f31");
309 _ -> SLIT("very naughty sparc register")
312 #if powerpc_TARGET_ARCH
314 ppr_reg_no :: Int -> Doc
317 0 -> SLIT("r0"); 1 -> SLIT("r1");
318 2 -> SLIT("r2"); 3 -> SLIT("r3");
319 4 -> SLIT("r4"); 5 -> SLIT("r5");
320 6 -> SLIT("r6"); 7 -> SLIT("r7");
321 8 -> SLIT("r8"); 9 -> SLIT("r9");
322 10 -> SLIT("r10"); 11 -> SLIT("r11");
323 12 -> SLIT("r12"); 13 -> SLIT("r13");
324 14 -> SLIT("r14"); 15 -> SLIT("r15");
325 16 -> SLIT("r16"); 17 -> SLIT("r17");
326 18 -> SLIT("r18"); 19 -> SLIT("r19");
327 20 -> SLIT("r20"); 21 -> SLIT("r21");
328 22 -> SLIT("r22"); 23 -> SLIT("r23");
329 24 -> SLIT("r24"); 25 -> SLIT("r25");
330 26 -> SLIT("r26"); 27 -> SLIT("r27");
331 28 -> SLIT("r28"); 29 -> SLIT("r29");
332 30 -> SLIT("r30"); 31 -> SLIT("r31");
333 32 -> SLIT("f0"); 33 -> SLIT("f1");
334 34 -> SLIT("f2"); 35 -> SLIT("f3");
335 36 -> SLIT("f4"); 37 -> SLIT("f5");
336 38 -> SLIT("f6"); 39 -> SLIT("f7");
337 40 -> SLIT("f8"); 41 -> SLIT("f9");
338 42 -> SLIT("f10"); 43 -> SLIT("f11");
339 44 -> SLIT("f12"); 45 -> SLIT("f13");
340 46 -> SLIT("f14"); 47 -> SLIT("f15");
341 48 -> SLIT("f16"); 49 -> SLIT("f17");
342 50 -> SLIT("f18"); 51 -> SLIT("f19");
343 52 -> SLIT("f20"); 53 -> SLIT("f21");
344 54 -> SLIT("f22"); 55 -> SLIT("f23");
345 56 -> SLIT("f24"); 57 -> SLIT("f25");
346 58 -> SLIT("f26"); 59 -> SLIT("f27");
347 60 -> SLIT("f28"); 61 -> SLIT("f29");
348 62 -> SLIT("f30"); 63 -> SLIT("f31");
349 _ -> SLIT("very naughty powerpc register")
352 ppr_reg_no :: Int -> Doc
353 ppr_reg_no i | i <= 31 = int i -- GPRs
354 | i <= 63 = int (i-32) -- FPRs
355 | otherwise = ptext SLIT("very naughty powerpc register")
360 -- -----------------------------------------------------------------------------
361 -- pprSize: print a 'Size'
363 #if powerpc_TARGET_ARCH || i386_TARGET_ARCH || x86_64_TARGET_ARCH || sparc_TARGET_ARCH
364 pprSize :: MachRep -> Doc
366 pprSize :: Size -> Doc
369 pprSize x = ptext (case x of
370 #if alpha_TARGET_ARCH
373 -- W -> SLIT("w") UNUSED
374 -- Wu -> SLIT("wu") UNUSED
377 -- FF -> SLIT("f") UNUSED
378 -- DF -> SLIT("d") UNUSED
379 -- GF -> SLIT("g") UNUSED
380 -- SF -> SLIT("s") UNUSED
383 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
394 #if x86_64_TARGET_ARCH
395 F32 -> SLIT("ss") -- "scalar single-precision float" (SSE2)
396 F64 -> SLIT("sd") -- "scalar double-precision float" (SSE2)
398 #if sparc_TARGET_ARCH
405 pprStSize :: MachRep -> Doc
406 pprStSize x = ptext (case x of
413 #if powerpc_TARGET_ARCH
422 -- -----------------------------------------------------------------------------
423 -- pprCond: print a 'Cond'
425 pprCond :: Cond -> Doc
427 pprCond c = ptext (case c of {
428 #if alpha_TARGET_ARCH
438 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
439 GEU -> SLIT("ae"); LU -> SLIT("b");
440 EQQ -> SLIT("e"); GTT -> SLIT("g");
441 GE -> SLIT("ge"); GU -> SLIT("a");
442 LTT -> SLIT("l"); LE -> SLIT("le");
443 LEU -> SLIT("be"); NE -> SLIT("ne");
444 NEG -> SLIT("s"); POS -> SLIT("ns");
445 CARRY -> SLIT("c"); OFLO -> SLIT("o");
446 PARITY -> SLIT("p"); NOTPARITY -> SLIT("np");
447 ALWAYS -> SLIT("mp") -- hack
449 #if sparc_TARGET_ARCH
450 ALWAYS -> SLIT(""); NEVER -> SLIT("n");
451 GEU -> SLIT("geu"); LU -> SLIT("lu");
452 EQQ -> SLIT("e"); GTT -> SLIT("g");
453 GE -> SLIT("ge"); GU -> SLIT("gu");
454 LTT -> SLIT("l"); LE -> SLIT("le");
455 LEU -> SLIT("leu"); NE -> SLIT("ne");
456 NEG -> SLIT("neg"); POS -> SLIT("pos");
457 VC -> SLIT("vc"); VS -> SLIT("vs")
459 #if powerpc_TARGET_ARCH
461 EQQ -> SLIT("eq"); NE -> SLIT("ne");
462 LTT -> SLIT("lt"); GE -> SLIT("ge");
463 GTT -> SLIT("gt"); LE -> SLIT("le");
464 LU -> SLIT("lt"); GEU -> SLIT("ge");
465 GU -> SLIT("gt"); LEU -> SLIT("le");
470 -- -----------------------------------------------------------------------------
471 -- pprImm: print an 'Imm'
475 pprImm (ImmInt i) = int i
476 pprImm (ImmInteger i) = integer i
477 pprImm (ImmCLbl l) = pprCLabel_asm l
478 pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i
479 pprImm (ImmLit s) = s
481 pprImm (ImmFloat _) = ptext SLIT("naughty float immediate")
482 pprImm (ImmDouble _) = ptext SLIT("naughty double immediate")
484 pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
485 #if sparc_TARGET_ARCH
486 -- ToDo: This should really be fixed in the PIC support, but only
488 pprImm (ImmConstantDiff a b) = pprImm a
490 pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
491 <> lparen <> pprImm b <> rparen
494 #if sparc_TARGET_ARCH
496 = hcat [ pp_lo, pprImm i, rparen ]
501 = hcat [ pp_hi, pprImm i, rparen ]
505 #if powerpc_TARGET_ARCH
508 = hcat [ pp_lo, pprImm i, rparen ]
513 = hcat [ pp_hi, pprImm i, rparen ]
518 = hcat [ pp_ha, pprImm i, rparen ]
524 = pprImm i <> text "@l"
527 = pprImm i <> text "@h"
530 = pprImm i <> text "@ha"
535 -- -----------------------------------------------------------------------------
536 -- @pprAddr: print an 'AddrMode'
538 pprAddr :: AddrMode -> Doc
540 #if alpha_TARGET_ARCH
541 pprAddr (AddrReg r) = parens (pprReg r)
542 pprAddr (AddrImm i) = pprImm i
543 pprAddr (AddrRegImm r1 i)
544 = (<>) (pprImm i) (parens (pprReg r1))
549 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
550 pprAddr (ImmAddr imm off)
551 = let pp_imm = pprImm imm
555 else if (off < 0) then
558 pp_imm <> char '+' <> int off
560 pprAddr (AddrBaseIndex base index displacement)
562 pp_disp = ppr_disp displacement
563 pp_off p = pp_disp <> char '(' <> p <> char ')'
564 pp_reg r = pprReg wordRep r
567 (EABaseNone, EAIndexNone) -> pp_disp
568 (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b)
569 (EABaseRip, EAIndexNone) -> pp_off (ptext SLIT("%rip"))
570 (EABaseNone, EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i)
571 (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r
574 ppr_disp (ImmInt 0) = empty
575 ppr_disp imm = pprImm imm
580 #if sparc_TARGET_ARCH
581 pprAddr (AddrRegReg r1 (RealReg 0)) = pprReg r1
583 pprAddr (AddrRegReg r1 r2)
584 = hcat [ pprReg r1, char '+', pprReg r2 ]
586 pprAddr (AddrRegImm r1 (ImmInt i))
588 | not (fits13Bits i) = largeOffsetError i
589 | otherwise = hcat [ pprReg r1, pp_sign, int i ]
591 pp_sign = if i > 0 then char '+' else empty
593 pprAddr (AddrRegImm r1 (ImmInteger i))
595 | not (fits13Bits i) = largeOffsetError i
596 | otherwise = hcat [ pprReg r1, pp_sign, integer i ]
598 pp_sign = if i > 0 then char '+' else empty
600 pprAddr (AddrRegImm r1 imm)
601 = hcat [ pprReg r1, char '+', pprImm imm ]
606 #if powerpc_TARGET_ARCH
607 pprAddr (AddrRegReg r1 r2)
608 = pprReg r1 <+> ptext SLIT(", ") <+> pprReg r2
610 pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ]
611 pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ]
612 pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]
616 -- -----------------------------------------------------------------------------
617 -- pprData: print a 'CmmStatic'
619 pprSectionHeader Text
621 IF_ARCH_alpha(SLIT("\t.text\n\t.align 3") {-word boundary-}
622 ,IF_ARCH_sparc(SLIT(".text\n\t.align 4") {-word boundary-}
623 ,IF_ARCH_i386(IF_OS_darwin(SLIT(".text\n\t.align 2"),
624 SLIT(".text\n\t.align 4,0x90"))
625 {-needs per-OS variation!-}
626 ,IF_ARCH_x86_64(SLIT(".text\n\t.align 8") {-needs per-OS variation!-}
627 ,IF_ARCH_powerpc(SLIT(".text\n.align 2")
629 pprSectionHeader Data
631 IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
632 ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
633 ,IF_ARCH_i386(IF_OS_darwin(SLIT(".data\n\t.align 2"),
634 SLIT(".data\n\t.align 4"))
635 ,IF_ARCH_x86_64(SLIT(".data\n\t.align 8")
636 ,IF_ARCH_powerpc(SLIT(".data\n.align 2")
638 pprSectionHeader ReadOnlyData
640 IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
641 ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
642 ,IF_ARCH_i386(IF_OS_darwin(SLIT(".const\n.align 2"),
643 SLIT(".section .rodata\n\t.align 4"))
644 ,IF_ARCH_x86_64(SLIT(".section .rodata\n\t.align 8")
645 ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const\n.align 2"),
646 SLIT(".section .rodata\n\t.align 2"))
648 pprSectionHeader RelocatableReadOnlyData
650 IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
651 ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
652 ,IF_ARCH_i386(IF_OS_darwin(SLIT(".const_data\n.align 2"),
653 SLIT(".section .rodata\n\t.align 4"))
654 ,IF_ARCH_x86_64(SLIT(".section .rodata\n\t.align 8")
655 ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const_data\n.align 2"),
656 SLIT(".data\n\t.align 2"))
658 pprSectionHeader UninitialisedData
660 IF_ARCH_alpha(SLIT("\t.bss\n\t.align 3")
661 ,IF_ARCH_sparc(SLIT(".bss\n\t.align 8") {-<8 will break double constants -}
662 ,IF_ARCH_i386(IF_OS_darwin(SLIT(".const_data\n\t.align 2"),
663 SLIT(".section .bss\n\t.align 4"))
664 ,IF_ARCH_x86_64(SLIT(".section .bss\n\t.align 8")
665 ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const_data\n.align 2"),
666 SLIT(".section .bss\n\t.align 2"))
668 pprSectionHeader ReadOnlyData16
670 IF_ARCH_alpha(SLIT("\t.data\n\t.align 4")
671 ,IF_ARCH_sparc(SLIT(".data\n\t.align 16")
672 ,IF_ARCH_i386(IF_OS_darwin(SLIT(".const\n.align 4"),
673 SLIT(".section .rodata\n\t.align 16"))
674 ,IF_ARCH_x86_64(SLIT(".section .rodata.cst16\n\t.align 16")
675 ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const\n.align 4"),
676 SLIT(".section .rodata\n\t.align 4"))
679 pprSectionHeader (OtherSection sec)
680 = panic "PprMach.pprSectionHeader: unknown section"
682 pprData :: CmmStatic -> Doc
683 pprData (CmmAlign bytes) = pprAlign bytes
684 pprData (CmmDataLabel lbl) = pprLabel lbl
685 pprData (CmmString str) = pprASCII str
686 pprData (CmmUninitialised bytes) = ptext SLIT(".space ") <> int bytes
687 pprData (CmmStaticLit lit) = pprDataItem lit
689 pprGloblDecl :: CLabel -> Doc
691 | not (externallyVisibleCLabel lbl) = empty
692 | otherwise = ptext IF_ARCH_sparc(SLIT(".global "),
696 pprLabel :: CLabel -> Doc
697 pprLabel lbl = pprGloblDecl lbl $$ (pprCLabel_asm lbl <> char ':')
700 -- Assume we want to backslash-convert the string
702 = vcat (map do1 (str ++ [chr 0]))
705 do1 c = ptext SLIT("\t.byte\t0x") <> hshow (ord c)
708 hshow n | n >= 0 && n <= 255
709 = char (tab !! (n `div` 16)) <> char (tab !! (n `mod` 16))
710 tab = "0123456789ABCDEF"
713 IF_ARCH_alpha(ptextSLIT(".align ") <> int pow2,
714 IF_ARCH_i386(ptext SLIT(".align ") <> int IF_OS_darwin(pow2,bytes),
715 IF_ARCH_x86_64(ptext SLIT(".align ") <> int bytes,
716 IF_ARCH_sparc(ptext SLIT(".align ") <> int bytes,
717 IF_ARCH_powerpc(ptext SLIT(".align ") <> int pow2,)))))
721 log2 :: Int -> Int -- cache the common ones
726 log2 n = 1 + log2 (n `quot` 2)
729 pprDataItem :: CmmLit -> Doc
731 = vcat (ppr_item (cmmLitRep lit) lit)
735 -- These seem to be common:
736 ppr_item I8 x = [ptext SLIT("\t.byte\t") <> pprImm imm]
737 ppr_item I32 x = [ptext SLIT("\t.long\t") <> pprImm imm]
738 ppr_item F32 (CmmFloat r _)
739 = let bs = floatToBytes (fromRational r)
740 in map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
741 ppr_item F64 (CmmFloat r _)
742 = let bs = doubleToBytes (fromRational r)
743 in map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
745 #if sparc_TARGET_ARCH
746 -- copy n paste of x86 version
747 ppr_item I16 x = [ptext SLIT("\t.short\t") <> pprImm imm]
748 ppr_item I64 x = [ptext SLIT("\t.quad\t") <> pprImm imm]
750 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
751 ppr_item I16 x = [ptext SLIT("\t.word\t") <> pprImm imm]
754 ppr_item I64 x = [ptext SLIT("\t.quad\t") <> pprImm imm]
756 #if x86_64_TARGET_ARCH
757 -- x86_64: binutils can't handle the R_X86_64_PC64 relocation
758 -- type, which means we can't do pc-relative 64-bit addresses.
759 -- Fortunately we're assuming the small memory model, in which
760 -- all such offsets will fit into 32 bits, so we have to stick
761 -- to 32-bit offset fields and modify the RTS appropriately
762 -- (see InfoTables.h).
765 | isRelativeReloc x =
766 [ptext SLIT("\t.long\t") <> pprImm imm,
767 ptext SLIT("\t.long\t0")]
769 [ptext SLIT("\t.quad\t") <> pprImm imm]
771 isRelativeReloc (CmmLabelOff _ _) = True
772 isRelativeReloc (CmmLabelDiffOff _ _ _) = True
773 isRelativeReloc _ = False
775 #if powerpc_TARGET_ARCH
776 ppr_item I16 x = [ptext SLIT("\t.short\t") <> pprImm imm]
777 ppr_item I64 (CmmInt x _) =
778 [ptext SLIT("\t.long\t")
780 (fromIntegral (x `shiftR` 32) :: Word32)),
781 ptext SLIT("\t.long\t")
782 <> int (fromIntegral (fromIntegral x :: Word32))]
785 -- fall through to rest of (machine-specific) pprInstr...
787 -- -----------------------------------------------------------------------------
788 -- pprInstr: print an 'Instr'
790 pprInstr :: Instr -> Doc
792 --pprInstr (COMMENT s) = empty -- nuke 'em
794 = IF_ARCH_alpha( ((<>) (ptext SLIT("\t# ")) (ftext s))
795 ,IF_ARCH_sparc( ((<>) (ptext SLIT("! ")) (ftext s))
796 ,IF_ARCH_i386( ((<>) (ptext SLIT("# ")) (ftext s))
797 ,IF_ARCH_x86_64( ((<>) (ptext SLIT("# ")) (ftext s))
798 ,IF_ARCH_powerpc( IF_OS_linux(
799 ((<>) (ptext SLIT("# ")) (ftext s)),
800 ((<>) (ptext SLIT("; ")) (ftext s)))
804 = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
806 pprInstr (NEWBLOCK _)
807 = panic "PprMach.pprInstr: NEWBLOCK"
810 = panic "PprMach.pprInstr: LDATA"
812 -- -----------------------------------------------------------------------------
813 -- pprInstr for an Alpha
815 #if alpha_TARGET_ARCH
817 pprInstr (LD size reg addr)
827 pprInstr (LDA reg addr)
829 ptext SLIT("\tlda\t"),
835 pprInstr (LDAH reg addr)
837 ptext SLIT("\tldah\t"),
843 pprInstr (LDGP reg addr)
845 ptext SLIT("\tldgp\t"),
851 pprInstr (LDI size reg imm)
861 pprInstr (ST size reg addr)
873 ptext SLIT("\tclr\t"),
877 pprInstr (ABS size ri reg)
887 pprInstr (NEG size ov ri reg)
891 if ov then ptext SLIT("v\t") else char '\t',
897 pprInstr (ADD size ov reg1 ri reg2)
901 if ov then ptext SLIT("v\t") else char '\t',
909 pprInstr (SADD size scale reg1 ri reg2)
911 ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
922 pprInstr (SUB size ov reg1 ri reg2)
926 if ov then ptext SLIT("v\t") else char '\t',
934 pprInstr (SSUB size scale reg1 ri reg2)
936 ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
947 pprInstr (MUL size ov reg1 ri reg2)
951 if ov then ptext SLIT("v\t") else char '\t',
959 pprInstr (DIV size uns reg1 ri reg2)
963 if uns then ptext SLIT("u\t") else char '\t',
971 pprInstr (REM size uns reg1 ri reg2)
975 if uns then ptext SLIT("u\t") else char '\t',
983 pprInstr (NOT ri reg)
992 pprInstr (AND reg1 ri reg2) = pprRegRIReg SLIT("and") reg1 ri reg2
993 pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg SLIT("andnot") reg1 ri reg2
994 pprInstr (OR reg1 ri reg2) = pprRegRIReg SLIT("or") reg1 ri reg2
995 pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg SLIT("ornot") reg1 ri reg2
996 pprInstr (XOR reg1 ri reg2) = pprRegRIReg SLIT("xor") reg1 ri reg2
997 pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg SLIT("xornot") reg1 ri reg2
999 pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") reg1 ri reg2
1000 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") reg1 ri reg2
1001 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") reg1 ri reg2
1003 pprInstr (ZAP reg1 ri reg2) = pprRegRIReg SLIT("zap") reg1 ri reg2
1004 pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg SLIT("zapnot") reg1 ri reg2
1006 pprInstr (NOP) = ptext SLIT("\tnop")
1008 pprInstr (CMP cond reg1 ri reg2)
1010 ptext SLIT("\tcmp"),
1022 ptext SLIT("\tfclr\t"),
1026 pprInstr (FABS reg1 reg2)
1028 ptext SLIT("\tfabs\t"),
1034 pprInstr (FNEG size reg1 reg2)
1036 ptext SLIT("\tneg"),
1044 pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("add") size reg1 reg2 reg3
1045 pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("div") size reg1 reg2 reg3
1046 pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("mul") size reg1 reg2 reg3
1047 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("sub") size reg1 reg2 reg3
1049 pprInstr (CVTxy size1 size2 reg1 reg2)
1051 ptext SLIT("\tcvt"),
1053 case size2 of {Q -> ptext SLIT("qc"); _ -> pprSize size2},
1060 pprInstr (FCMP size cond reg1 reg2 reg3)
1062 ptext SLIT("\tcmp"),
1073 pprInstr (FMOV reg1 reg2)
1075 ptext SLIT("\tfmov\t"),
1081 pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
1083 pprInstr (BI NEVER reg lab) = empty
1085 pprInstr (BI cond reg lab)
1095 pprInstr (BF cond reg lab)
1106 = (<>) (ptext SLIT("\tbr\t")) (pprImm lab)
1108 pprInstr (JMP reg addr hint)
1110 ptext SLIT("\tjmp\t"),
1118 pprInstr (BSR imm n)
1119 = (<>) (ptext SLIT("\tbsr\t")) (pprImm imm)
1121 pprInstr (JSR reg addr n)
1123 ptext SLIT("\tjsr\t"),
1129 pprInstr (FUNBEGIN clab)
1131 if (externallyVisibleCLabel clab) then
1132 hcat [ptext SLIT("\t.globl\t"), pp_lab, char '\n']
1135 ptext SLIT("\t.ent "),
1144 pp_lab = pprCLabel_asm clab
1146 -- NEVER use commas within those string literals, cpp will ruin your day
1147 pp_ldgp = hcat [ ptext SLIT(":\n\tldgp $29"), char ',', ptext SLIT("0($27)\n") ]
1148 pp_frame = hcat [ ptext SLIT("..ng:\n\t.frame $30"), char ',',
1149 ptext SLIT("4240"), char ',',
1150 ptext SLIT("$26"), char ',',
1151 ptext SLIT("0\n\t.prologue 1") ]
1153 pprInstr (FUNEND clab)
1154 = (<>) (ptext SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab)
1157 Continue with Alpha-only printing bits and bobs:
1161 pprRI (RIReg r) = pprReg r
1162 pprRI (RIImm r) = pprImm r
1164 pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
1165 pprRegRIReg name reg1 ri reg2
1177 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1178 pprSizeRegRegReg name size reg1 reg2 reg3
1191 #endif /* alpha_TARGET_ARCH */
1194 -- -----------------------------------------------------------------------------
1195 -- pprInstr for an x86
1197 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1199 pprInstr v@(MOV size s@(OpReg src) d@(OpReg dst)) -- hack
1202 #if 0 /* #ifdef DEBUG */
1203 (<>) (ptext SLIT("# warning: ")) (pprSizeOpOp SLIT("mov") size s d)
1208 pprInstr (MOV size src dst)
1209 = pprSizeOpOp SLIT("mov") size src dst
1211 pprInstr (MOVZxL I32 src dst) = pprSizeOpOp SLIT("mov") I32 src dst
1212 -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple
1213 -- movl. But we represent it as a MOVZxL instruction, because
1214 -- the reg alloc would tend to throw away a plain reg-to-reg
1215 -- move, and we still want it to do that.
1217 pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce SLIT("movz") sizes I32 src dst
1218 -- zero-extension only needs to extend to 32 bits: on x86_64,
1219 -- the remaining zero-extension to 64 bits is automatic, and the 32-bit
1220 -- instruction is shorter.
1222 pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce SLIT("movs") sizes wordRep src dst
1224 -- here we do some patching, since the physical registers are only set late
1225 -- in the code generation.
1226 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1228 = pprSizeOpOp SLIT("add") size (OpReg reg2) dst
1229 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1231 = pprSizeOpOp SLIT("add") size (OpReg reg1) dst
1232 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))
1234 = pprInstr (ADD size (OpImm displ) dst)
1235 pprInstr (LEA size src dst) = pprSizeOpOp SLIT("lea") size src dst
1237 pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
1238 = pprSizeOp SLIT("dec") size dst
1239 pprInstr (ADD size (OpImm (ImmInt 1)) dst)
1240 = pprSizeOp SLIT("inc") size dst
1241 pprInstr (ADD size src dst)
1242 = pprSizeOpOp SLIT("add") size src dst
1243 pprInstr (ADC size src dst)
1244 = pprSizeOpOp SLIT("adc") size src dst
1245 pprInstr (SUB size src dst) = pprSizeOpOp SLIT("sub") size src dst
1246 pprInstr (IMUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2
1248 {- A hack. The Intel documentation says that "The two and three
1249 operand forms [of IMUL] may also be used with unsigned operands
1250 because the lower half of the product is the same regardless if
1251 (sic) the operands are signed or unsigned. The CF and OF flags,
1252 however, cannot be used to determine if the upper half of the
1253 result is non-zero." So there.
1255 pprInstr (AND size src dst) = pprSizeOpOp SLIT("and") size src dst
1256 pprInstr (OR size src dst) = pprSizeOpOp SLIT("or") size src dst
1258 pprInstr (XOR F32 src dst) = pprOpOp SLIT("xorps") F32 src dst
1259 pprInstr (XOR F64 src dst) = pprOpOp SLIT("xorpd") F64 src dst
1260 pprInstr (XOR size src dst) = pprSizeOpOp SLIT("xor") size src dst
1262 pprInstr (NOT size op) = pprSizeOp SLIT("not") size op
1263 pprInstr (NEGI size op) = pprSizeOp SLIT("neg") size op
1265 pprInstr (SHL size src dst) = pprShift SLIT("shl") size src dst
1266 pprInstr (SAR size src dst) = pprShift SLIT("sar") size src dst
1267 pprInstr (SHR size src dst) = pprShift SLIT("shr") size src dst
1269 pprInstr (BT size imm src) = pprSizeImmOp SLIT("bt") size imm src
1271 pprInstr (CMP size src dst)
1272 | isFloatingRep size = pprSizeOpOp SLIT("ucomi") size src dst -- SSE2
1273 | otherwise = pprSizeOpOp SLIT("cmp") size src dst
1275 pprInstr (TEST size src dst) = pprSizeOpOp SLIT("test") size src dst
1276 pprInstr (PUSH size op) = pprSizeOp SLIT("push") size op
1277 pprInstr (POP size op) = pprSizeOp SLIT("pop") size op
1279 -- both unused (SDM):
1280 -- pprInstr PUSHA = ptext SLIT("\tpushal")
1281 -- pprInstr POPA = ptext SLIT("\tpopal")
1283 pprInstr NOP = ptext SLIT("\tnop")
1284 pprInstr (CLTD I32) = ptext SLIT("\tcltd")
1285 pprInstr (CLTD I64) = ptext SLIT("\tcqto")
1287 pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand I8 op)
1289 pprInstr (JXX cond (BlockId id))
1290 = pprCondInstr SLIT("j") cond (pprCLabel_asm lab)
1291 where lab = mkAsmTempLabel id
1293 pprInstr (JMP (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
1294 pprInstr (JMP op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand wordRep op)
1295 pprInstr (JMP_TBL op ids) = pprInstr (JMP op)
1296 pprInstr (CALL (Left imm) _) = (<>) (ptext SLIT("\tcall ")) (pprImm imm)
1297 pprInstr (CALL (Right reg) _) = (<>) (ptext SLIT("\tcall *")) (pprReg wordRep reg)
1299 pprInstr (IDIV sz op) = pprSizeOp SLIT("idiv") sz op
1300 pprInstr (DIV sz op) = pprSizeOp SLIT("div") sz op
1301 pprInstr (IMUL2 sz op) = pprSizeOp SLIT("imul") sz op
1303 #if x86_64_TARGET_ARCH
1304 pprInstr (MUL size op1 op2) = pprSizeOpOp SLIT("mul") size op1 op2
1306 pprInstr (FDIV size op1 op2) = pprSizeOpOp SLIT("div") size op1 op2
1308 pprInstr (CVTSS2SD from to) = pprRegReg SLIT("cvtss2sd") from to
1309 pprInstr (CVTSD2SS from to) = pprRegReg SLIT("cvtsd2ss") from to
1310 pprInstr (CVTSS2SI from to) = pprOpReg SLIT("cvtss2si") from to
1311 pprInstr (CVTSD2SI from to) = pprOpReg SLIT("cvtsd2si") from to
1312 pprInstr (CVTSI2SS from to) = pprOpReg SLIT("cvtsi2ss") from to
1313 pprInstr (CVTSI2SD from to) = pprOpReg SLIT("cvtsi2sd") from to
1316 -- FETCHGOT for PIC on ELF platforms
1317 pprInstr (FETCHGOT reg)
1318 = vcat [ ptext SLIT("\tcall 1f"),
1319 hcat [ ptext SLIT("1:\tpopl\t"), pprReg I32 reg ],
1320 hcat [ ptext SLIT("\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "),
1324 -- FETCHPC for PIC on Darwin/x86
1325 -- get the instruction pointer into a register
1326 -- (Terminology note: the IP is called Program Counter on PPC,
1327 -- and it's a good thing to use the same name on both platforms)
1328 pprInstr (FETCHPC reg)
1329 = vcat [ ptext SLIT("\tcall 1f"),
1330 hcat [ ptext SLIT("1:\tpopl\t"), pprReg I32 reg ]
1337 -- -----------------------------------------------------------------------------
1338 -- i386 floating-point
1340 #if i386_TARGET_ARCH
1341 -- Simulating a flat register set on the x86 FP stack is tricky.
1342 -- you have to free %st(7) before pushing anything on the FP reg stack
1343 -- so as to preclude the possibility of a FP stack overflow exception.
1344 pprInstr g@(GMOV src dst)
1348 = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
1350 -- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FSTP (dst+1)
1351 pprInstr g@(GLD sz addr dst)
1352 = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp,
1353 pprAddr addr, gsemi, gpop dst 1])
1355 -- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
1356 pprInstr g@(GST sz src addr)
1357 = pprG g (hcat [gtab, gpush src 0, gsemi,
1358 text "fstp", pprSize sz, gsp, pprAddr addr])
1360 pprInstr g@(GLDZ dst)
1361 = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1])
1362 pprInstr g@(GLD1 dst)
1363 = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1])
1365 pprInstr g@(GFTOI src dst)
1366 = pprInstr (GDTOI src dst)
1367 pprInstr g@(GDTOI src dst)
1368 = pprG g (hcat [gtab, text "subl $4, %esp ; ",
1369 gpush src 0, gsemi, text "fistpl 0(%esp) ; popl ",
1372 pprInstr g@(GITOF src dst)
1373 = pprInstr (GITOD src dst)
1374 pprInstr g@(GITOD src dst)
1375 = pprG g (hcat [gtab, text "pushl ", pprReg I32 src,
1376 text " ; ffree %st(7); fildl (%esp) ; ",
1377 gpop dst 1, text " ; addl $4,%esp"])
1379 {- Gruesome swamp follows. If you're unfortunate enough to have ventured
1380 this far into the jungle AND you give a Rat's Ass (tm) what's going
1381 on, here's the deal. Generate code to do a floating point comparison
1382 of src1 and src2, of kind cond, and set the Zero flag if true.
1384 The complications are to do with handling NaNs correctly. We want the
1385 property that if either argument is NaN, then the result of the
1386 comparison is False ... except if we're comparing for inequality,
1387 in which case the answer is True.
1389 Here's how the general (non-inequality) case works. As an
1390 example, consider generating the an equality test:
1392 pushl %eax -- we need to mess with this
1393 <get src1 to top of FPU stack>
1394 fcomp <src2 location in FPU stack> and pop pushed src1
1395 -- Result of comparison is in FPU Status Register bits
1397 fstsw %ax -- Move FPU Status Reg to %ax
1398 sahf -- move C3 C2 C0 from %ax to integer flag reg
1399 -- now the serious magic begins
1400 setpo %ah -- %ah = if comparable(neither arg was NaN) then 1 else 0
1401 sete %al -- %al = if arg1 == arg2 then 1 else 0
1402 andb %ah,%al -- %al &= %ah
1403 -- so %al == 1 iff (comparable && same); else it holds 0
1404 decb %al -- %al == 0, ZeroFlag=1 iff (comparable && same);
1405 else %al == 0xFF, ZeroFlag=0
1406 -- the zero flag is now set as we desire.
1409 The special case of inequality differs thusly:
1411 setpe %ah -- %ah = if incomparable(either arg was NaN) then 1 else 0
1412 setne %al -- %al = if arg1 /= arg2 then 1 else 0
1413 orb %ah,%al -- %al = if (incomparable || different) then 1 else 0
1414 decb %al -- if (incomparable || different) then (%al == 0, ZF=1)
1415 else (%al == 0xFF, ZF=0)
1417 pprInstr g@(GCMP cond src1 src2)
1418 | case cond of { NE -> True; other -> False }
1420 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1421 hcat [gtab, text "fcomp ", greg src2 1,
1422 text "; fstsw %ax ; sahf ; setpe %ah"],
1423 hcat [gtab, text "setne %al ; ",
1424 text "orb %ah,%al ; decb %al ; popl %eax"]
1428 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1429 hcat [gtab, text "fcomp ", greg src2 1,
1430 text "; fstsw %ax ; sahf ; setpo %ah"],
1431 hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ; ",
1432 text "andb %ah,%al ; decb %al ; popl %eax"]
1435 {- On the 486, the flags set by FP compare are the unsigned ones!
1436 (This looks like a HACK to me. WDP 96/03)
1438 fix_FP_cond :: Cond -> Cond
1439 fix_FP_cond GE = GEU
1440 fix_FP_cond GTT = GU
1441 fix_FP_cond LTT = LU
1442 fix_FP_cond LE = LEU
1443 fix_FP_cond EQQ = EQQ
1445 -- there should be no others
1448 pprInstr g@(GABS sz src dst)
1449 = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
1450 pprInstr g@(GNEG sz src dst)
1451 = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
1453 pprInstr g@(GSQRT sz src dst)
1454 = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
1455 hcat [gtab, gcoerceto sz, gpop dst 1])
1456 pprInstr g@(GSIN sz src dst)
1457 = pprG g (hcat [gtab, gpush src 0, text " ; fsin"] $$
1458 hcat [gtab, gcoerceto sz, gpop dst 1])
1459 pprInstr g@(GCOS sz src dst)
1460 = pprG g (hcat [gtab, gpush src 0, text " ; fcos"] $$
1461 hcat [gtab, gcoerceto sz, gpop dst 1])
1462 pprInstr g@(GTAN sz src dst)
1463 = pprG g (hcat [gtab, text "ffree %st(6) ; ",
1464 gpush src 0, text " ; fptan ; ",
1465 text " fstp %st(0)"] $$
1466 hcat [gtab, gcoerceto sz, gpop dst 1])
1468 -- In the translations for GADD, GMUL, GSUB and GDIV,
1469 -- the first two cases are mere optimisations. The otherwise clause
1470 -- generates correct code under all circumstances.
1472 pprInstr g@(GADD sz src1 src2 dst)
1474 = pprG g (text "\t#GADD-xxxcase1" $$
1475 hcat [gtab, gpush src2 0,
1476 text " ; faddp %st(0),", greg src1 1])
1478 = pprG g (text "\t#GADD-xxxcase2" $$
1479 hcat [gtab, gpush src1 0,
1480 text " ; faddp %st(0),", greg src2 1])
1482 = pprG g (hcat [gtab, gpush src1 0,
1483 text " ; fadd ", greg src2 1, text ",%st(0)",
1487 pprInstr g@(GMUL sz src1 src2 dst)
1489 = pprG g (text "\t#GMUL-xxxcase1" $$
1490 hcat [gtab, gpush src2 0,
1491 text " ; fmulp %st(0),", greg src1 1])
1493 = pprG g (text "\t#GMUL-xxxcase2" $$
1494 hcat [gtab, gpush src1 0,
1495 text " ; fmulp %st(0),", greg src2 1])
1497 = pprG g (hcat [gtab, gpush src1 0,
1498 text " ; fmul ", greg src2 1, text ",%st(0)",
1502 pprInstr g@(GSUB sz src1 src2 dst)
1504 = pprG g (text "\t#GSUB-xxxcase1" $$
1505 hcat [gtab, gpush src2 0,
1506 text " ; fsubrp %st(0),", greg src1 1])
1508 = pprG g (text "\t#GSUB-xxxcase2" $$
1509 hcat [gtab, gpush src1 0,
1510 text " ; fsubp %st(0),", greg src2 1])
1512 = pprG g (hcat [gtab, gpush src1 0,
1513 text " ; fsub ", greg src2 1, text ",%st(0)",
1517 pprInstr g@(GDIV sz src1 src2 dst)
1519 = pprG g (text "\t#GDIV-xxxcase1" $$
1520 hcat [gtab, gpush src2 0,
1521 text " ; fdivrp %st(0),", greg src1 1])
1523 = pprG g (text "\t#GDIV-xxxcase2" $$
1524 hcat [gtab, gpush src1 0,
1525 text " ; fdivp %st(0),", greg src2 1])
1527 = pprG g (hcat [gtab, gpush src1 0,
1528 text " ; fdiv ", greg src2 1, text ",%st(0)",
1533 = vcat [ ptext SLIT("\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
1534 ptext SLIT("\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)")
1537 --------------------------
1539 -- coerce %st(0) to the specified size
1540 gcoerceto F64 = empty
1541 gcoerceto F32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
1544 = hcat [text "ffree %st(7) ; fld ", greg reg offset]
1546 = hcat [text "fstp ", greg reg offset]
1548 greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
1553 gregno (RealReg i) = i
1554 gregno other = --pprPanic "gregno" (ppr other)
1555 999 -- bogus; only needed for debug printing
1557 pprG :: Instr -> Doc -> Doc
1559 = (char '#' <> pprGInstr fake) $$ actual
1561 pprGInstr (GMOV src dst) = pprSizeRegReg SLIT("gmov") F64 src dst
1562 pprGInstr (GLD sz src dst) = pprSizeAddrReg SLIT("gld") sz src dst
1563 pprGInstr (GST sz src dst) = pprSizeRegAddr SLIT("gst") sz src dst
1565 pprGInstr (GLDZ dst) = pprSizeReg SLIT("gldz") F64 dst
1566 pprGInstr (GLD1 dst) = pprSizeReg SLIT("gld1") F64 dst
1568 pprGInstr (GFTOI src dst) = pprSizeSizeRegReg SLIT("gftoi") F32 I32 src dst
1569 pprGInstr (GDTOI src dst) = pprSizeSizeRegReg SLIT("gdtoi") F64 I32 src dst
1571 pprGInstr (GITOF src dst) = pprSizeSizeRegReg SLIT("gitof") I32 F32 src dst
1572 pprGInstr (GITOD src dst) = pprSizeSizeRegReg SLIT("gitod") I32 F64 src dst
1574 pprGInstr (GCMP co src dst) = pprCondRegReg SLIT("gcmp_") F64 co src dst
1575 pprGInstr (GABS sz src dst) = pprSizeRegReg SLIT("gabs") sz src dst
1576 pprGInstr (GNEG sz src dst) = pprSizeRegReg SLIT("gneg") sz src dst
1577 pprGInstr (GSQRT sz src dst) = pprSizeRegReg SLIT("gsqrt") sz src dst
1578 pprGInstr (GSIN sz src dst) = pprSizeRegReg SLIT("gsin") sz src dst
1579 pprGInstr (GCOS sz src dst) = pprSizeRegReg SLIT("gcos") sz src dst
1580 pprGInstr (GTAN sz src dst) = pprSizeRegReg SLIT("gtan") sz src dst
1582 pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg SLIT("gadd") sz src1 src2 dst
1583 pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg SLIT("gsub") sz src1 src2 dst
1584 pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg SLIT("gmul") sz src1 src2 dst
1585 pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg SLIT("gdiv") sz src1 src2 dst
1588 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1590 -- Continue with I386-only printing bits and bobs:
1592 pprDollImm :: Imm -> Doc
1594 pprDollImm i = ptext SLIT("$") <> pprImm i
1596 pprOperand :: MachRep -> Operand -> Doc
1597 pprOperand s (OpReg r) = pprReg s r
1598 pprOperand s (OpImm i) = pprDollImm i
1599 pprOperand s (OpAddr ea) = pprAddr ea
1601 pprMnemonic_ :: LitString -> Doc
1603 char '\t' <> ptext name <> space
1605 pprMnemonic :: LitString -> MachRep -> Doc
1606 pprMnemonic name size =
1607 char '\t' <> ptext name <> pprSize size <> space
1609 pprSizeImmOp :: LitString -> MachRep -> Imm -> Operand -> Doc
1610 pprSizeImmOp name size imm op1
1612 pprMnemonic name size,
1619 pprSizeOp :: LitString -> MachRep -> Operand -> Doc
1620 pprSizeOp name size op1
1622 pprMnemonic name size,
1626 pprSizeOpOp :: LitString -> MachRep -> Operand -> Operand -> Doc
1627 pprSizeOpOp name size op1 op2
1629 pprMnemonic name size,
1630 pprOperand size op1,
1635 pprOpOp :: LitString -> MachRep -> Operand -> Operand -> Doc
1636 pprOpOp name size op1 op2
1639 pprOperand size op1,
1644 pprSizeReg :: LitString -> MachRep -> Reg -> Doc
1645 pprSizeReg name size reg1
1647 pprMnemonic name size,
1651 pprSizeRegReg :: LitString -> MachRep -> Reg -> Reg -> Doc
1652 pprSizeRegReg name size reg1 reg2
1654 pprMnemonic name size,
1660 pprRegReg :: LitString -> Reg -> Reg -> Doc
1661 pprRegReg name reg1 reg2
1664 pprReg wordRep reg1,
1669 pprOpReg :: LitString -> Operand -> Reg -> Doc
1670 pprOpReg name op1 reg2
1673 pprOperand wordRep op1,
1678 pprCondRegReg :: LitString -> MachRep -> Cond -> Reg -> Reg -> Doc
1679 pprCondRegReg name size cond reg1 reg2
1690 pprSizeSizeRegReg :: LitString -> MachRep -> MachRep -> Reg -> Reg -> Doc
1691 pprSizeSizeRegReg name size1 size2 reg1 reg2
1704 pprSizeRegRegReg :: LitString -> MachRep -> Reg -> Reg -> Reg -> Doc
1705 pprSizeRegRegReg name size reg1 reg2 reg3
1707 pprMnemonic name size,
1715 pprSizeAddrReg :: LitString -> MachRep -> AddrMode -> Reg -> Doc
1716 pprSizeAddrReg name size op dst
1718 pprMnemonic name size,
1724 pprSizeRegAddr :: LitString -> MachRep -> Reg -> AddrMode -> Doc
1725 pprSizeRegAddr name size src op
1727 pprMnemonic name size,
1733 pprShift :: LitString -> MachRep -> Operand -> Operand -> Doc
1734 pprShift name size src dest
1736 pprMnemonic name size,
1737 pprOperand I8 src, -- src is 8-bit sized
1739 pprOperand size dest
1742 pprSizeOpOpCoerce :: LitString -> MachRep -> MachRep -> Operand -> Operand -> Doc
1743 pprSizeOpOpCoerce name size1 size2 op1 op2
1744 = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
1745 pprOperand size1 op1,
1747 pprOperand size2 op2
1750 pprCondInstr :: LitString -> Cond -> Doc -> Doc
1751 pprCondInstr name cond arg
1752 = hcat [ char '\t', ptext name, pprCond cond, space, arg]
1754 #endif /* i386_TARGET_ARCH */
1757 -- ------------------------------------------------------------------------------- pprInstr for a SPARC
1759 #if sparc_TARGET_ARCH
1761 -- a clumsy hack for now, to handle possible double alignment problems
1763 -- even clumsier, to allow for RegReg regs that show when doing indexed
1764 -- reads (bytearrays).
1767 -- Translate to the following:
1770 -- ld [g1+4],%f(n+1)
1771 -- sub g1,g2,g1 -- to restore g1
1773 pprInstr (LD F64 (AddrRegReg g1 g2) reg)
1775 hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1776 hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg],
1777 hcat [pp_ld_lbracket, pprReg g1, ptext SLIT("+4]"), comma, pprReg (fPair reg)],
1778 hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1783 -- ld [addr+4],%f(n+1)
1784 pprInstr (LD F64 addr reg) | isJust off_addr
1786 hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
1787 hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg (fPair reg)]
1790 off_addr = addrOffset addr 4
1791 addr2 = case off_addr of Just x -> x
1794 pprInstr (LD size addr reg)
1805 -- The same clumsy hack as above
1807 -- Translate to the following:
1810 -- st %f(n+1),[g1+4]
1811 -- sub g1,g2,g1 -- to restore g1
1812 pprInstr (ST F64 reg (AddrRegReg g1 g2))
1814 hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1815 hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1817 hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1818 pprReg g1, ptext SLIT("+4]")],
1819 hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1824 -- st %f(n+1),[addr+4]
1825 pprInstr (ST F64 reg addr) | isJust off_addr
1827 hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1828 pprAddr addr, rbrack],
1829 hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1830 pprAddr addr2, rbrack]
1833 off_addr = addrOffset addr 4
1834 addr2 = case off_addr of Just x -> x
1836 -- no distinction is made between signed and unsigned bytes on stores for the
1837 -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
1838 -- so we call a special-purpose pprSize for ST..
1840 pprInstr (ST size reg addr)
1851 pprInstr (ADD x cc reg1 ri reg2)
1852 | not x && not cc && riZero ri
1853 = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1855 = pprRegRIReg (if x then SLIT("addx") else SLIT("add")) cc reg1 ri reg2
1857 pprInstr (SUB x cc reg1 ri reg2)
1858 | not x && cc && reg2 == g0
1859 = hcat [ ptext SLIT("\tcmp\t"), pprReg reg1, comma, pprRI ri ]
1860 | not x && not cc && riZero ri
1861 = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1863 = pprRegRIReg (if x then SLIT("subx") else SLIT("sub")) cc reg1 ri reg2
1865 pprInstr (AND b reg1 ri reg2) = pprRegRIReg SLIT("and") b reg1 ri reg2
1866 pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg SLIT("andn") b reg1 ri reg2
1868 pprInstr (OR b reg1 ri reg2)
1869 | not b && reg1 == g0
1870 = let doit = hcat [ ptext SLIT("\tmov\t"), pprRI ri, comma, pprReg reg2 ]
1872 RIReg rrr | rrr == reg2 -> empty
1875 = pprRegRIReg SLIT("or") b reg1 ri reg2
1877 pprInstr (ORN b reg1 ri reg2) = pprRegRIReg SLIT("orn") b reg1 ri reg2
1879 pprInstr (XOR b reg1 ri reg2) = pprRegRIReg SLIT("xor") b reg1 ri reg2
1880 pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg SLIT("xnor") b reg1 ri reg2
1882 pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") False reg1 ri reg2
1883 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") False reg1 ri reg2
1884 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") False reg1 ri reg2
1886 pprInstr (RDY rd) = ptext SLIT("\trd\t%y,") <> pprReg rd
1887 pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg SLIT("smul") b reg1 ri reg2
1888 pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg SLIT("umul") b reg1 ri reg2
1890 pprInstr (SETHI imm reg)
1892 ptext SLIT("\tsethi\t"),
1898 pprInstr NOP = ptext SLIT("\tnop")
1900 pprInstr (FABS F32 reg1 reg2) = pprSizeRegReg SLIT("fabs") F32 reg1 reg2
1901 pprInstr (FABS F64 reg1 reg2)
1902 = (<>) (pprSizeRegReg SLIT("fabs") F32 reg1 reg2)
1903 (if (reg1 == reg2) then empty
1904 else (<>) (char '\n')
1905 (pprSizeRegReg SLIT("fmov") F32 (fPair reg1) (fPair reg2)))
1907 pprInstr (FADD size reg1 reg2 reg3)
1908 = pprSizeRegRegReg SLIT("fadd") size reg1 reg2 reg3
1909 pprInstr (FCMP e size reg1 reg2)
1910 = pprSizeRegReg (if e then SLIT("fcmpe") else SLIT("fcmp")) size reg1 reg2
1911 pprInstr (FDIV size reg1 reg2 reg3)
1912 = pprSizeRegRegReg SLIT("fdiv") size reg1 reg2 reg3
1914 pprInstr (FMOV F32 reg1 reg2) = pprSizeRegReg SLIT("fmov") F32 reg1 reg2
1915 pprInstr (FMOV F64 reg1 reg2)
1916 = (<>) (pprSizeRegReg SLIT("fmov") F32 reg1 reg2)
1917 (if (reg1 == reg2) then empty
1918 else (<>) (char '\n')
1919 (pprSizeRegReg SLIT("fmov") F32 (fPair reg1) (fPair reg2)))
1921 pprInstr (FMUL size reg1 reg2 reg3)
1922 = pprSizeRegRegReg SLIT("fmul") size reg1 reg2 reg3
1924 pprInstr (FNEG F32 reg1 reg2) = pprSizeRegReg SLIT("fneg") F32 reg1 reg2
1925 pprInstr (FNEG F64 reg1 reg2)
1926 = (<>) (pprSizeRegReg SLIT("fneg") F32 reg1 reg2)
1927 (if (reg1 == reg2) then empty
1928 else (<>) (char '\n')
1929 (pprSizeRegReg SLIT("fmov") F32 (fPair reg1) (fPair reg2)))
1931 pprInstr (FSQRT size reg1 reg2) = pprSizeRegReg SLIT("fsqrt") size reg1 reg2
1932 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fsub") size reg1 reg2 reg3
1933 pprInstr (FxTOy size1 size2 reg1 reg2)
1940 F64 -> SLIT("dto")),
1945 F64 -> SLIT("d\t")),
1946 pprReg reg1, comma, pprReg reg2
1950 pprInstr (BI cond b lab)
1952 ptext SLIT("\tb"), pprCond cond,
1953 if b then pp_comma_a else empty,
1958 pprInstr (BF cond b lab)
1960 ptext SLIT("\tfb"), pprCond cond,
1961 if b then pp_comma_a else empty,
1966 pprInstr (JMP addr) = (<>) (ptext SLIT("\tjmp\t")) (pprAddr addr)
1968 pprInstr (CALL (Left imm) n _)
1969 = hcat [ ptext SLIT("\tcall\t"), pprImm imm, comma, int n ]
1970 pprInstr (CALL (Right reg) n _)
1971 = hcat [ ptext SLIT("\tcall\t"), pprReg reg, comma, int n ]
1974 pprRI (RIReg r) = pprReg r
1975 pprRI (RIImm r) = pprImm r
1977 pprSizeRegReg :: LitString -> MachRep -> Reg -> Reg -> Doc
1978 pprSizeRegReg name size reg1 reg2
1983 F32 -> ptext SLIT("s\t")
1984 F64 -> ptext SLIT("d\t")),
1990 pprSizeRegRegReg :: LitString -> MachRep -> Reg -> Reg -> Reg -> Doc
1991 pprSizeRegRegReg name size reg1 reg2 reg3
1996 F32 -> ptext SLIT("s\t")
1997 F64 -> ptext SLIT("d\t")),
2005 pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
2006 pprRegRIReg name b reg1 ri reg2
2010 if b then ptext SLIT("cc\t") else char '\t',
2018 pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
2019 pprRIReg name b ri reg1
2023 if b then ptext SLIT("cc\t") else char '\t',
2029 pp_ld_lbracket = ptext SLIT("\tld\t[")
2030 pp_rbracket_comma = text "],"
2031 pp_comma_lbracket = text ",["
2032 pp_comma_a = text ",a"
2034 #endif /* sparc_TARGET_ARCH */
2037 -- -----------------------------------------------------------------------------
2038 -- pprInstr for PowerPC
2040 #if powerpc_TARGET_ARCH
2041 pprInstr (LD sz reg addr) = hcat [
2050 case addr of AddrRegImm _ _ -> empty
2051 AddrRegReg _ _ -> char 'x',
2057 pprInstr (LA sz reg addr) = hcat [
2066 case addr of AddrRegImm _ _ -> empty
2067 AddrRegReg _ _ -> char 'x',
2073 pprInstr (ST sz reg addr) = hcat [
2077 case addr of AddrRegImm _ _ -> empty
2078 AddrRegReg _ _ -> char 'x',
2084 pprInstr (STU sz reg addr) = hcat [
2089 case addr of AddrRegImm _ _ -> empty
2090 AddrRegReg _ _ -> char 'x',
2095 pprInstr (LIS reg imm) = hcat [
2103 pprInstr (LI reg imm) = hcat [
2111 pprInstr (MR reg1 reg2)
2112 | reg1 == reg2 = empty
2113 | otherwise = hcat [
2115 case regClass reg1 of
2116 RcInteger -> ptext SLIT("mr")
2117 _ -> ptext SLIT("fmr"),
2123 pprInstr (CMP sz reg ri) = hcat [
2139 pprInstr (CMPL sz reg ri) = hcat [
2155 pprInstr (BCC cond (BlockId id)) = hcat [
2162 where lbl = mkAsmTempLabel id
2164 pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
2171 pprInstr (MTCTR reg) = hcat [
2173 ptext SLIT("mtctr"),
2177 pprInstr (BCTR _) = hcat [
2181 pprInstr (BL lbl _) = hcat [
2182 ptext SLIT("\tbl\t"),
2185 pprInstr (BCTRL _) = hcat [
2189 pprInstr (ADD reg1 reg2 ri) = pprLogic SLIT("add") reg1 reg2 ri
2190 pprInstr (ADDIS reg1 reg2 imm) = hcat [
2192 ptext SLIT("addis"),
2201 pprInstr (ADDC reg1 reg2 reg3) = pprLogic SLIT("addc") reg1 reg2 (RIReg reg3)
2202 pprInstr (ADDE reg1 reg2 reg3) = pprLogic SLIT("adde") reg1 reg2 (RIReg reg3)
2203 pprInstr (SUBF reg1 reg2 reg3) = pprLogic SLIT("subf") reg1 reg2 (RIReg reg3)
2204 pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic SLIT("mullw") reg1 reg2 ri
2205 pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic SLIT("mull") reg1 reg2 ri
2206 pprInstr (DIVW reg1 reg2 reg3) = pprLogic SLIT("divw") reg1 reg2 (RIReg reg3)
2207 pprInstr (DIVWU reg1 reg2 reg3) = pprLogic SLIT("divwu") reg1 reg2 (RIReg reg3)
2209 pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
2210 hcat [ ptext SLIT("\tmullwo\t"), pprReg reg1, ptext SLIT(", "),
2211 pprReg reg2, ptext SLIT(", "),
2213 hcat [ ptext SLIT("\tmfxer\t"), pprReg reg1 ],
2214 hcat [ ptext SLIT("\trlwinm\t"), pprReg reg1, ptext SLIT(", "),
2215 pprReg reg1, ptext SLIT(", "),
2216 ptext SLIT("2, 31, 31") ]
2219 -- for some reason, "andi" doesn't exist.
2220 -- we'll use "andi." instead.
2221 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
2223 ptext SLIT("andi."),
2231 pprInstr (AND reg1 reg2 ri) = pprLogic SLIT("and") reg1 reg2 ri
2233 pprInstr (OR reg1 reg2 ri) = pprLogic SLIT("or") reg1 reg2 ri
2234 pprInstr (XOR reg1 reg2 ri) = pprLogic SLIT("xor") reg1 reg2 ri
2236 pprInstr (XORIS reg1 reg2 imm) = hcat [
2238 ptext SLIT("xoris"),
2247 pprInstr (EXTS sz reg1 reg2) = hcat [
2257 pprInstr (NEG reg1 reg2) = pprUnary SLIT("neg") reg1 reg2
2258 pprInstr (NOT reg1 reg2) = pprUnary SLIT("not") reg1 reg2
2260 pprInstr (SLW reg1 reg2 ri) = pprLogic SLIT("slw") reg1 reg2 (limitShiftRI ri)
2261 pprInstr (SRW reg1 reg2 ri) = pprLogic SLIT("srw") reg1 reg2 (limitShiftRI ri)
2262 pprInstr (SRAW reg1 reg2 ri) = pprLogic SLIT("sraw") reg1 reg2 (limitShiftRI ri)
2263 pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
2264 ptext SLIT("\trlwinm\t"),
2276 pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF SLIT("fadd") sz reg1 reg2 reg3
2277 pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF SLIT("fsub") sz reg1 reg2 reg3
2278 pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF SLIT("fmul") sz reg1 reg2 reg3
2279 pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF SLIT("fdiv") sz reg1 reg2 reg3
2280 pprInstr (FNEG reg1 reg2) = pprUnary SLIT("fneg") reg1 reg2
2282 pprInstr (FCMP reg1 reg2) = hcat [
2284 ptext SLIT("fcmpu\tcr0, "),
2285 -- Note: we're using fcmpu, not fcmpo
2286 -- The difference is with fcmpo, compare with NaN is an invalid operation.
2287 -- We don't handle invalid fp ops, so we don't care
2293 pprInstr (FCTIWZ reg1 reg2) = pprUnary SLIT("fctiwz") reg1 reg2
2294 pprInstr (FRSP reg1 reg2) = pprUnary SLIT("frsp") reg1 reg2
2296 pprInstr (CRNOR dst src1 src2) = hcat [
2297 ptext SLIT("\tcrnor\t"),
2305 pprInstr (MFCR reg) = hcat [
2312 pprInstr (MFLR reg) = hcat [
2319 pprInstr (FETCHPC reg) = vcat [
2320 ptext SLIT("\tbcl\t20,31,1f"),
2321 hcat [ ptext SLIT("1:\tmflr\t"), pprReg reg ]
2324 pprInstr _ = panic "pprInstr (ppc)"
2326 pprLogic op reg1 reg2 ri = hcat [
2331 RIImm _ -> char 'i',
2340 pprUnary op reg1 reg2 = hcat [
2349 pprBinaryF op sz reg1 reg2 reg3 = hcat [
2362 pprRI (RIReg r) = pprReg r
2363 pprRI (RIImm r) = pprImm r
2365 pprFSize F64 = empty
2366 pprFSize F32 = char 's'
2368 -- limit immediate argument for shift instruction to range 0..32
2369 -- (yes, the maximum is really 32, not 31)
2370 limitShiftRI :: RI -> RI
2371 limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32)
2374 #endif /* powerpc_TARGET_ARCH */
2377 -- -----------------------------------------------------------------------------
2378 -- Converting floating-point literals to integrals for printing
2380 #if __GLASGOW_HASKELL__ >= 504
2381 newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
2382 newFloatArray = newArray_
2384 newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
2385 newDoubleArray = newArray_
2387 castFloatToCharArray :: STUArray s Int Float -> ST s (STUArray s Int Word8)
2388 castFloatToCharArray = castSTUArray
2390 castDoubleToCharArray :: STUArray s Int Double -> ST s (STUArray s Int Word8)
2391 castDoubleToCharArray = castSTUArray
2393 writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
2394 writeFloatArray = writeArray
2396 writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
2397 writeDoubleArray = writeArray
2399 readCharArray :: STUArray s Int Word8 -> Int -> ST s Char
2400 readCharArray arr i = do
2401 w <- readArray arr i
2402 return $! (chr (fromIntegral w))
2406 castFloatToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2407 castFloatToCharArray = return
2409 castDoubleToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2412 castDoubleToCharArray = return
2416 -- floatToBytes and doubleToBytes convert to the host's byte
2417 -- order. Providing that we're not cross-compiling for a
2418 -- target with the opposite endianness, this should work ok
2421 -- ToDo: this stuff is very similar to the shenanigans in PprAbs,
2422 -- could they be merged?
2424 floatToBytes :: Float -> [Int]
2427 arr <- newFloatArray ((0::Int),3)
2428 writeFloatArray arr 0 f
2429 arr <- castFloatToCharArray arr
2430 i0 <- readCharArray arr 0
2431 i1 <- readCharArray arr 1
2432 i2 <- readCharArray arr 2
2433 i3 <- readCharArray arr 3
2434 return (map ord [i0,i1,i2,i3])
2437 doubleToBytes :: Double -> [Int]
2440 arr <- newDoubleArray ((0::Int),7)
2441 writeDoubleArray arr 0 d
2442 arr <- castDoubleToCharArray arr
2443 i0 <- readCharArray arr 0
2444 i1 <- readCharArray arr 1
2445 i2 <- readCharArray arr 2
2446 i3 <- readCharArray arr 3
2447 i4 <- readCharArray arr 4
2448 i5 <- readCharArray arr 5
2449 i6 <- readCharArray arr 6
2450 i7 <- readCharArray arr 7
2451 return (map ord [i0,i1,i2,i3,i4,i5,i6,i7])