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 || darwin_TARGET_OS
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 ':')
701 = vcat (map do1 str) $$ do1 0
704 do1 w = ptext SLIT("\t.byte\t") <> int (fromIntegral w)
707 IF_ARCH_alpha(ptextSLIT(".align ") <> int pow2,
708 IF_ARCH_i386(ptext SLIT(".align ") <> int IF_OS_darwin(pow2,bytes),
709 IF_ARCH_x86_64(ptext SLIT(".align ") <> int bytes,
710 IF_ARCH_sparc(ptext SLIT(".align ") <> int bytes,
711 IF_ARCH_powerpc(ptext SLIT(".align ") <> int pow2,)))))
715 log2 :: Int -> Int -- cache the common ones
720 log2 n = 1 + log2 (n `quot` 2)
723 pprDataItem :: CmmLit -> Doc
725 = vcat (ppr_item (cmmLitRep lit) lit)
729 -- These seem to be common:
730 ppr_item I8 x = [ptext SLIT("\t.byte\t") <> pprImm imm]
731 ppr_item I32 x = [ptext SLIT("\t.long\t") <> pprImm imm]
732 ppr_item F32 (CmmFloat r _)
733 = let bs = floatToBytes (fromRational r)
734 in map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
735 ppr_item F64 (CmmFloat r _)
736 = let bs = doubleToBytes (fromRational r)
737 in map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
739 #if sparc_TARGET_ARCH
740 -- copy n paste of x86 version
741 ppr_item I16 x = [ptext SLIT("\t.short\t") <> pprImm imm]
742 ppr_item I64 x = [ptext SLIT("\t.quad\t") <> pprImm imm]
744 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
745 ppr_item I16 x = [ptext SLIT("\t.word\t") <> pprImm imm]
747 #if i386_TARGET_ARCH && darwin_TARGET_OS
748 ppr_item I64 (CmmInt x _) =
749 [ptext SLIT("\t.long\t")
750 <> int (fromIntegral (fromIntegral x :: Word32)),
751 ptext SLIT("\t.long\t")
753 (fromIntegral (x `shiftR` 32) :: Word32))]
756 ppr_item I64 x = [ptext SLIT("\t.quad\t") <> pprImm imm]
758 #if x86_64_TARGET_ARCH
759 -- x86_64: binutils can't handle the R_X86_64_PC64 relocation
760 -- type, which means we can't do pc-relative 64-bit addresses.
761 -- Fortunately we're assuming the small memory model, in which
762 -- all such offsets will fit into 32 bits, so we have to stick
763 -- to 32-bit offset fields and modify the RTS appropriately
764 -- (see InfoTables.h).
767 | isRelativeReloc x =
768 [ptext SLIT("\t.long\t") <> pprImm imm,
769 ptext SLIT("\t.long\t0")]
771 [ptext SLIT("\t.quad\t") <> pprImm imm]
773 isRelativeReloc (CmmLabelOff _ _) = True
774 isRelativeReloc (CmmLabelDiffOff _ _ _) = True
775 isRelativeReloc _ = False
777 #if powerpc_TARGET_ARCH
778 ppr_item I16 x = [ptext SLIT("\t.short\t") <> pprImm imm]
779 ppr_item I64 (CmmInt x _) =
780 [ptext SLIT("\t.long\t")
782 (fromIntegral (x `shiftR` 32) :: Word32)),
783 ptext SLIT("\t.long\t")
784 <> int (fromIntegral (fromIntegral x :: Word32))]
787 -- fall through to rest of (machine-specific) pprInstr...
789 -- -----------------------------------------------------------------------------
790 -- pprInstr: print an 'Instr'
792 pprInstr :: Instr -> Doc
794 --pprInstr (COMMENT s) = empty -- nuke 'em
796 = IF_ARCH_alpha( ((<>) (ptext SLIT("\t# ")) (ftext s))
797 ,IF_ARCH_sparc( ((<>) (ptext SLIT("! ")) (ftext s))
798 ,IF_ARCH_i386( ((<>) (ptext SLIT("# ")) (ftext s))
799 ,IF_ARCH_x86_64( ((<>) (ptext SLIT("# ")) (ftext s))
800 ,IF_ARCH_powerpc( IF_OS_linux(
801 ((<>) (ptext SLIT("# ")) (ftext s)),
802 ((<>) (ptext SLIT("; ")) (ftext s)))
806 = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
808 pprInstr (NEWBLOCK _)
809 = panic "PprMach.pprInstr: NEWBLOCK"
812 = panic "PprMach.pprInstr: LDATA"
814 -- -----------------------------------------------------------------------------
815 -- pprInstr for an Alpha
817 #if alpha_TARGET_ARCH
819 pprInstr (LD size reg addr)
829 pprInstr (LDA reg addr)
831 ptext SLIT("\tlda\t"),
837 pprInstr (LDAH reg addr)
839 ptext SLIT("\tldah\t"),
845 pprInstr (LDGP reg addr)
847 ptext SLIT("\tldgp\t"),
853 pprInstr (LDI size reg imm)
863 pprInstr (ST size reg addr)
875 ptext SLIT("\tclr\t"),
879 pprInstr (ABS size ri reg)
889 pprInstr (NEG size ov ri reg)
893 if ov then ptext SLIT("v\t") else char '\t',
899 pprInstr (ADD size ov reg1 ri reg2)
903 if ov then ptext SLIT("v\t") else char '\t',
911 pprInstr (SADD size scale reg1 ri reg2)
913 ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
924 pprInstr (SUB size ov reg1 ri reg2)
928 if ov then ptext SLIT("v\t") else char '\t',
936 pprInstr (SSUB size scale reg1 ri reg2)
938 ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
949 pprInstr (MUL size ov reg1 ri reg2)
953 if ov then ptext SLIT("v\t") else char '\t',
961 pprInstr (DIV size uns reg1 ri reg2)
965 if uns then ptext SLIT("u\t") else char '\t',
973 pprInstr (REM size uns reg1 ri reg2)
977 if uns then ptext SLIT("u\t") else char '\t',
985 pprInstr (NOT ri reg)
994 pprInstr (AND reg1 ri reg2) = pprRegRIReg SLIT("and") reg1 ri reg2
995 pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg SLIT("andnot") reg1 ri reg2
996 pprInstr (OR reg1 ri reg2) = pprRegRIReg SLIT("or") reg1 ri reg2
997 pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg SLIT("ornot") reg1 ri reg2
998 pprInstr (XOR reg1 ri reg2) = pprRegRIReg SLIT("xor") reg1 ri reg2
999 pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg SLIT("xornot") reg1 ri reg2
1001 pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") reg1 ri reg2
1002 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") reg1 ri reg2
1003 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") reg1 ri reg2
1005 pprInstr (ZAP reg1 ri reg2) = pprRegRIReg SLIT("zap") reg1 ri reg2
1006 pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg SLIT("zapnot") reg1 ri reg2
1008 pprInstr (NOP) = ptext SLIT("\tnop")
1010 pprInstr (CMP cond reg1 ri reg2)
1012 ptext SLIT("\tcmp"),
1024 ptext SLIT("\tfclr\t"),
1028 pprInstr (FABS reg1 reg2)
1030 ptext SLIT("\tfabs\t"),
1036 pprInstr (FNEG size reg1 reg2)
1038 ptext SLIT("\tneg"),
1046 pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("add") size reg1 reg2 reg3
1047 pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("div") size reg1 reg2 reg3
1048 pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("mul") size reg1 reg2 reg3
1049 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("sub") size reg1 reg2 reg3
1051 pprInstr (CVTxy size1 size2 reg1 reg2)
1053 ptext SLIT("\tcvt"),
1055 case size2 of {Q -> ptext SLIT("qc"); _ -> pprSize size2},
1062 pprInstr (FCMP size cond reg1 reg2 reg3)
1064 ptext SLIT("\tcmp"),
1075 pprInstr (FMOV reg1 reg2)
1077 ptext SLIT("\tfmov\t"),
1083 pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
1085 pprInstr (BI NEVER reg lab) = empty
1087 pprInstr (BI cond reg lab)
1097 pprInstr (BF cond reg lab)
1108 = (<>) (ptext SLIT("\tbr\t")) (pprImm lab)
1110 pprInstr (JMP reg addr hint)
1112 ptext SLIT("\tjmp\t"),
1120 pprInstr (BSR imm n)
1121 = (<>) (ptext SLIT("\tbsr\t")) (pprImm imm)
1123 pprInstr (JSR reg addr n)
1125 ptext SLIT("\tjsr\t"),
1131 pprInstr (FUNBEGIN clab)
1133 if (externallyVisibleCLabel clab) then
1134 hcat [ptext SLIT("\t.globl\t"), pp_lab, char '\n']
1137 ptext SLIT("\t.ent "),
1146 pp_lab = pprCLabel_asm clab
1148 -- NEVER use commas within those string literals, cpp will ruin your day
1149 pp_ldgp = hcat [ ptext SLIT(":\n\tldgp $29"), char ',', ptext SLIT("0($27)\n") ]
1150 pp_frame = hcat [ ptext SLIT("..ng:\n\t.frame $30"), char ',',
1151 ptext SLIT("4240"), char ',',
1152 ptext SLIT("$26"), char ',',
1153 ptext SLIT("0\n\t.prologue 1") ]
1155 pprInstr (FUNEND clab)
1156 = (<>) (ptext SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab)
1159 Continue with Alpha-only printing bits and bobs:
1163 pprRI (RIReg r) = pprReg r
1164 pprRI (RIImm r) = pprImm r
1166 pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
1167 pprRegRIReg name reg1 ri reg2
1179 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1180 pprSizeRegRegReg name size reg1 reg2 reg3
1193 #endif /* alpha_TARGET_ARCH */
1196 -- -----------------------------------------------------------------------------
1197 -- pprInstr for an x86
1199 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1201 pprInstr v@(MOV size s@(OpReg src) d@(OpReg dst)) -- hack
1204 #if 0 /* #ifdef DEBUG */
1205 (<>) (ptext SLIT("# warning: ")) (pprSizeOpOp SLIT("mov") size s d)
1210 pprInstr (MOV size src dst)
1211 = pprSizeOpOp SLIT("mov") size src dst
1213 pprInstr (MOVZxL I32 src dst) = pprSizeOpOp SLIT("mov") I32 src dst
1214 -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple
1215 -- movl. But we represent it as a MOVZxL instruction, because
1216 -- the reg alloc would tend to throw away a plain reg-to-reg
1217 -- move, and we still want it to do that.
1219 pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce SLIT("movz") sizes I32 src dst
1220 -- zero-extension only needs to extend to 32 bits: on x86_64,
1221 -- the remaining zero-extension to 64 bits is automatic, and the 32-bit
1222 -- instruction is shorter.
1224 pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce SLIT("movs") sizes wordRep src dst
1226 -- here we do some patching, since the physical registers are only set late
1227 -- in the code generation.
1228 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1230 = pprSizeOpOp SLIT("add") size (OpReg reg2) dst
1231 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1233 = pprSizeOpOp SLIT("add") size (OpReg reg1) dst
1234 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))
1236 = pprInstr (ADD size (OpImm displ) dst)
1237 pprInstr (LEA size src dst) = pprSizeOpOp SLIT("lea") size src dst
1239 pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
1240 = pprSizeOp SLIT("dec") size dst
1241 pprInstr (ADD size (OpImm (ImmInt 1)) dst)
1242 = pprSizeOp SLIT("inc") size dst
1243 pprInstr (ADD size src dst)
1244 = pprSizeOpOp SLIT("add") size src dst
1245 pprInstr (ADC size src dst)
1246 = pprSizeOpOp SLIT("adc") size src dst
1247 pprInstr (SUB size src dst) = pprSizeOpOp SLIT("sub") size src dst
1248 pprInstr (IMUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2
1250 {- A hack. The Intel documentation says that "The two and three
1251 operand forms [of IMUL] may also be used with unsigned operands
1252 because the lower half of the product is the same regardless if
1253 (sic) the operands are signed or unsigned. The CF and OF flags,
1254 however, cannot be used to determine if the upper half of the
1255 result is non-zero." So there.
1257 pprInstr (AND size src dst) = pprSizeOpOp SLIT("and") size src dst
1258 pprInstr (OR size src dst) = pprSizeOpOp SLIT("or") size src dst
1260 pprInstr (XOR F32 src dst) = pprOpOp SLIT("xorps") F32 src dst
1261 pprInstr (XOR F64 src dst) = pprOpOp SLIT("xorpd") F64 src dst
1262 pprInstr (XOR size src dst) = pprSizeOpOp SLIT("xor") size src dst
1264 pprInstr (NOT size op) = pprSizeOp SLIT("not") size op
1265 pprInstr (NEGI size op) = pprSizeOp SLIT("neg") size op
1267 pprInstr (SHL size src dst) = pprShift SLIT("shl") size src dst
1268 pprInstr (SAR size src dst) = pprShift SLIT("sar") size src dst
1269 pprInstr (SHR size src dst) = pprShift SLIT("shr") size src dst
1271 pprInstr (BT size imm src) = pprSizeImmOp SLIT("bt") size imm src
1273 pprInstr (CMP size src dst)
1274 | isFloatingRep size = pprSizeOpOp SLIT("ucomi") size src dst -- SSE2
1275 | otherwise = pprSizeOpOp SLIT("cmp") size src dst
1277 pprInstr (TEST size src dst) = pprSizeOpOp SLIT("test") size src dst
1278 pprInstr (PUSH size op) = pprSizeOp SLIT("push") size op
1279 pprInstr (POP size op) = pprSizeOp SLIT("pop") size op
1281 -- both unused (SDM):
1282 -- pprInstr PUSHA = ptext SLIT("\tpushal")
1283 -- pprInstr POPA = ptext SLIT("\tpopal")
1285 pprInstr NOP = ptext SLIT("\tnop")
1286 pprInstr (CLTD I32) = ptext SLIT("\tcltd")
1287 pprInstr (CLTD I64) = ptext SLIT("\tcqto")
1289 pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand I8 op)
1291 pprInstr (JXX cond (BlockId id))
1292 = pprCondInstr SLIT("j") cond (pprCLabel_asm lab)
1293 where lab = mkAsmTempLabel id
1295 pprInstr (JMP (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
1296 pprInstr (JMP op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand wordRep op)
1297 pprInstr (JMP_TBL op ids) = pprInstr (JMP op)
1298 pprInstr (CALL (Left imm) _) = (<>) (ptext SLIT("\tcall ")) (pprImm imm)
1299 pprInstr (CALL (Right reg) _) = (<>) (ptext SLIT("\tcall *")) (pprReg wordRep reg)
1301 pprInstr (IDIV sz op) = pprSizeOp SLIT("idiv") sz op
1302 pprInstr (DIV sz op) = pprSizeOp SLIT("div") sz op
1303 pprInstr (IMUL2 sz op) = pprSizeOp SLIT("imul") sz op
1305 #if x86_64_TARGET_ARCH
1306 pprInstr (MUL size op1 op2) = pprSizeOpOp SLIT("mul") size op1 op2
1308 pprInstr (FDIV size op1 op2) = pprSizeOpOp SLIT("div") size op1 op2
1310 pprInstr (CVTSS2SD from to) = pprRegReg SLIT("cvtss2sd") from to
1311 pprInstr (CVTSD2SS from to) = pprRegReg SLIT("cvtsd2ss") from to
1312 pprInstr (CVTSS2SI from to) = pprOpReg SLIT("cvtss2si") from to
1313 pprInstr (CVTSD2SI from to) = pprOpReg SLIT("cvtsd2si") from to
1314 pprInstr (CVTSI2SS from to) = pprOpReg SLIT("cvtsi2ss") from to
1315 pprInstr (CVTSI2SD from to) = pprOpReg SLIT("cvtsi2sd") from to
1318 -- FETCHGOT for PIC on ELF platforms
1319 pprInstr (FETCHGOT reg)
1320 = vcat [ ptext SLIT("\tcall 1f"),
1321 hcat [ ptext SLIT("1:\tpopl\t"), pprReg I32 reg ],
1322 hcat [ ptext SLIT("\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "),
1326 -- FETCHPC for PIC on Darwin/x86
1327 -- get the instruction pointer into a register
1328 -- (Terminology note: the IP is called Program Counter on PPC,
1329 -- and it's a good thing to use the same name on both platforms)
1330 pprInstr (FETCHPC reg)
1331 = vcat [ ptext SLIT("\tcall 1f"),
1332 hcat [ ptext SLIT("1:\tpopl\t"), pprReg I32 reg ]
1339 -- -----------------------------------------------------------------------------
1340 -- i386 floating-point
1342 #if i386_TARGET_ARCH
1343 -- Simulating a flat register set on the x86 FP stack is tricky.
1344 -- you have to free %st(7) before pushing anything on the FP reg stack
1345 -- so as to preclude the possibility of a FP stack overflow exception.
1346 pprInstr g@(GMOV src dst)
1350 = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
1352 -- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FSTP (dst+1)
1353 pprInstr g@(GLD sz addr dst)
1354 = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp,
1355 pprAddr addr, gsemi, gpop dst 1])
1357 -- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
1358 pprInstr g@(GST sz src addr)
1359 = pprG g (hcat [gtab, gpush src 0, gsemi,
1360 text "fstp", pprSize sz, gsp, pprAddr addr])
1362 pprInstr g@(GLDZ dst)
1363 = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1])
1364 pprInstr g@(GLD1 dst)
1365 = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1])
1367 pprInstr g@(GFTOI src dst)
1368 = pprInstr (GDTOI src dst)
1369 pprInstr g@(GDTOI src dst)
1370 = pprG g (hcat [gtab, text "subl $4, %esp ; ",
1371 gpush src 0, gsemi, text "fistpl 0(%esp) ; popl ",
1374 pprInstr g@(GITOF src dst)
1375 = pprInstr (GITOD src dst)
1376 pprInstr g@(GITOD src dst)
1377 = pprG g (hcat [gtab, text "pushl ", pprReg I32 src,
1378 text " ; ffree %st(7); fildl (%esp) ; ",
1379 gpop dst 1, text " ; addl $4,%esp"])
1381 {- Gruesome swamp follows. If you're unfortunate enough to have ventured
1382 this far into the jungle AND you give a Rat's Ass (tm) what's going
1383 on, here's the deal. Generate code to do a floating point comparison
1384 of src1 and src2, of kind cond, and set the Zero flag if true.
1386 The complications are to do with handling NaNs correctly. We want the
1387 property that if either argument is NaN, then the result of the
1388 comparison is False ... except if we're comparing for inequality,
1389 in which case the answer is True.
1391 Here's how the general (non-inequality) case works. As an
1392 example, consider generating the an equality test:
1394 pushl %eax -- we need to mess with this
1395 <get src1 to top of FPU stack>
1396 fcomp <src2 location in FPU stack> and pop pushed src1
1397 -- Result of comparison is in FPU Status Register bits
1399 fstsw %ax -- Move FPU Status Reg to %ax
1400 sahf -- move C3 C2 C0 from %ax to integer flag reg
1401 -- now the serious magic begins
1402 setpo %ah -- %ah = if comparable(neither arg was NaN) then 1 else 0
1403 sete %al -- %al = if arg1 == arg2 then 1 else 0
1404 andb %ah,%al -- %al &= %ah
1405 -- so %al == 1 iff (comparable && same); else it holds 0
1406 decb %al -- %al == 0, ZeroFlag=1 iff (comparable && same);
1407 else %al == 0xFF, ZeroFlag=0
1408 -- the zero flag is now set as we desire.
1411 The special case of inequality differs thusly:
1413 setpe %ah -- %ah = if incomparable(either arg was NaN) then 1 else 0
1414 setne %al -- %al = if arg1 /= arg2 then 1 else 0
1415 orb %ah,%al -- %al = if (incomparable || different) then 1 else 0
1416 decb %al -- if (incomparable || different) then (%al == 0, ZF=1)
1417 else (%al == 0xFF, ZF=0)
1419 pprInstr g@(GCMP cond src1 src2)
1420 | case cond of { NE -> True; other -> False }
1422 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1423 hcat [gtab, text "fcomp ", greg src2 1,
1424 text "; fstsw %ax ; sahf ; setpe %ah"],
1425 hcat [gtab, text "setne %al ; ",
1426 text "orb %ah,%al ; decb %al ; popl %eax"]
1430 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1431 hcat [gtab, text "fcomp ", greg src2 1,
1432 text "; fstsw %ax ; sahf ; setpo %ah"],
1433 hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ; ",
1434 text "andb %ah,%al ; decb %al ; popl %eax"]
1437 {- On the 486, the flags set by FP compare are the unsigned ones!
1438 (This looks like a HACK to me. WDP 96/03)
1440 fix_FP_cond :: Cond -> Cond
1441 fix_FP_cond GE = GEU
1442 fix_FP_cond GTT = GU
1443 fix_FP_cond LTT = LU
1444 fix_FP_cond LE = LEU
1445 fix_FP_cond EQQ = EQQ
1447 -- there should be no others
1450 pprInstr g@(GABS sz src dst)
1451 = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
1452 pprInstr g@(GNEG sz src dst)
1453 = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
1455 pprInstr g@(GSQRT sz src dst)
1456 = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
1457 hcat [gtab, gcoerceto sz, gpop dst 1])
1458 pprInstr g@(GSIN sz src dst)
1459 = pprG g (hcat [gtab, gpush src 0, text " ; fsin"] $$
1460 hcat [gtab, gcoerceto sz, gpop dst 1])
1461 pprInstr g@(GCOS sz src dst)
1462 = pprG g (hcat [gtab, gpush src 0, text " ; fcos"] $$
1463 hcat [gtab, gcoerceto sz, gpop dst 1])
1464 pprInstr g@(GTAN sz src dst)
1465 = pprG g (hcat [gtab, text "ffree %st(6) ; ",
1466 gpush src 0, text " ; fptan ; ",
1467 text " fstp %st(0)"] $$
1468 hcat [gtab, gcoerceto sz, gpop dst 1])
1470 -- In the translations for GADD, GMUL, GSUB and GDIV,
1471 -- the first two cases are mere optimisations. The otherwise clause
1472 -- generates correct code under all circumstances.
1474 pprInstr g@(GADD sz src1 src2 dst)
1476 = pprG g (text "\t#GADD-xxxcase1" $$
1477 hcat [gtab, gpush src2 0,
1478 text " ; faddp %st(0),", greg src1 1])
1480 = pprG g (text "\t#GADD-xxxcase2" $$
1481 hcat [gtab, gpush src1 0,
1482 text " ; faddp %st(0),", greg src2 1])
1484 = pprG g (hcat [gtab, gpush src1 0,
1485 text " ; fadd ", greg src2 1, text ",%st(0)",
1489 pprInstr g@(GMUL sz src1 src2 dst)
1491 = pprG g (text "\t#GMUL-xxxcase1" $$
1492 hcat [gtab, gpush src2 0,
1493 text " ; fmulp %st(0),", greg src1 1])
1495 = pprG g (text "\t#GMUL-xxxcase2" $$
1496 hcat [gtab, gpush src1 0,
1497 text " ; fmulp %st(0),", greg src2 1])
1499 = pprG g (hcat [gtab, gpush src1 0,
1500 text " ; fmul ", greg src2 1, text ",%st(0)",
1504 pprInstr g@(GSUB sz src1 src2 dst)
1506 = pprG g (text "\t#GSUB-xxxcase1" $$
1507 hcat [gtab, gpush src2 0,
1508 text " ; fsubrp %st(0),", greg src1 1])
1510 = pprG g (text "\t#GSUB-xxxcase2" $$
1511 hcat [gtab, gpush src1 0,
1512 text " ; fsubp %st(0),", greg src2 1])
1514 = pprG g (hcat [gtab, gpush src1 0,
1515 text " ; fsub ", greg src2 1, text ",%st(0)",
1519 pprInstr g@(GDIV sz src1 src2 dst)
1521 = pprG g (text "\t#GDIV-xxxcase1" $$
1522 hcat [gtab, gpush src2 0,
1523 text " ; fdivrp %st(0),", greg src1 1])
1525 = pprG g (text "\t#GDIV-xxxcase2" $$
1526 hcat [gtab, gpush src1 0,
1527 text " ; fdivp %st(0),", greg src2 1])
1529 = pprG g (hcat [gtab, gpush src1 0,
1530 text " ; fdiv ", greg src2 1, text ",%st(0)",
1535 = vcat [ ptext SLIT("\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
1536 ptext SLIT("\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)")
1539 --------------------------
1541 -- coerce %st(0) to the specified size
1542 gcoerceto F64 = empty
1543 gcoerceto F32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
1546 = hcat [text "ffree %st(7) ; fld ", greg reg offset]
1548 = hcat [text "fstp ", greg reg offset]
1550 greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
1555 gregno (RealReg i) = i
1556 gregno other = --pprPanic "gregno" (ppr other)
1557 999 -- bogus; only needed for debug printing
1559 pprG :: Instr -> Doc -> Doc
1561 = (char '#' <> pprGInstr fake) $$ actual
1563 pprGInstr (GMOV src dst) = pprSizeRegReg SLIT("gmov") F64 src dst
1564 pprGInstr (GLD sz src dst) = pprSizeAddrReg SLIT("gld") sz src dst
1565 pprGInstr (GST sz src dst) = pprSizeRegAddr SLIT("gst") sz src dst
1567 pprGInstr (GLDZ dst) = pprSizeReg SLIT("gldz") F64 dst
1568 pprGInstr (GLD1 dst) = pprSizeReg SLIT("gld1") F64 dst
1570 pprGInstr (GFTOI src dst) = pprSizeSizeRegReg SLIT("gftoi") F32 I32 src dst
1571 pprGInstr (GDTOI src dst) = pprSizeSizeRegReg SLIT("gdtoi") F64 I32 src dst
1573 pprGInstr (GITOF src dst) = pprSizeSizeRegReg SLIT("gitof") I32 F32 src dst
1574 pprGInstr (GITOD src dst) = pprSizeSizeRegReg SLIT("gitod") I32 F64 src dst
1576 pprGInstr (GCMP co src dst) = pprCondRegReg SLIT("gcmp_") F64 co src dst
1577 pprGInstr (GABS sz src dst) = pprSizeRegReg SLIT("gabs") sz src dst
1578 pprGInstr (GNEG sz src dst) = pprSizeRegReg SLIT("gneg") sz src dst
1579 pprGInstr (GSQRT sz src dst) = pprSizeRegReg SLIT("gsqrt") sz src dst
1580 pprGInstr (GSIN sz src dst) = pprSizeRegReg SLIT("gsin") sz src dst
1581 pprGInstr (GCOS sz src dst) = pprSizeRegReg SLIT("gcos") sz src dst
1582 pprGInstr (GTAN sz src dst) = pprSizeRegReg SLIT("gtan") sz src dst
1584 pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg SLIT("gadd") sz src1 src2 dst
1585 pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg SLIT("gsub") sz src1 src2 dst
1586 pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg SLIT("gmul") sz src1 src2 dst
1587 pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg SLIT("gdiv") sz src1 src2 dst
1590 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1592 -- Continue with I386-only printing bits and bobs:
1594 pprDollImm :: Imm -> Doc
1596 pprDollImm i = ptext SLIT("$") <> pprImm i
1598 pprOperand :: MachRep -> Operand -> Doc
1599 pprOperand s (OpReg r) = pprReg s r
1600 pprOperand s (OpImm i) = pprDollImm i
1601 pprOperand s (OpAddr ea) = pprAddr ea
1603 pprMnemonic_ :: LitString -> Doc
1605 char '\t' <> ptext name <> space
1607 pprMnemonic :: LitString -> MachRep -> Doc
1608 pprMnemonic name size =
1609 char '\t' <> ptext name <> pprSize size <> space
1611 pprSizeImmOp :: LitString -> MachRep -> Imm -> Operand -> Doc
1612 pprSizeImmOp name size imm op1
1614 pprMnemonic name size,
1621 pprSizeOp :: LitString -> MachRep -> Operand -> Doc
1622 pprSizeOp name size op1
1624 pprMnemonic name size,
1628 pprSizeOpOp :: LitString -> MachRep -> Operand -> Operand -> Doc
1629 pprSizeOpOp name size op1 op2
1631 pprMnemonic name size,
1632 pprOperand size op1,
1637 pprOpOp :: LitString -> MachRep -> Operand -> Operand -> Doc
1638 pprOpOp name size op1 op2
1641 pprOperand size op1,
1646 pprSizeReg :: LitString -> MachRep -> Reg -> Doc
1647 pprSizeReg name size reg1
1649 pprMnemonic name size,
1653 pprSizeRegReg :: LitString -> MachRep -> Reg -> Reg -> Doc
1654 pprSizeRegReg name size reg1 reg2
1656 pprMnemonic name size,
1662 pprRegReg :: LitString -> Reg -> Reg -> Doc
1663 pprRegReg name reg1 reg2
1666 pprReg wordRep reg1,
1671 pprOpReg :: LitString -> Operand -> Reg -> Doc
1672 pprOpReg name op1 reg2
1675 pprOperand wordRep op1,
1680 pprCondRegReg :: LitString -> MachRep -> Cond -> Reg -> Reg -> Doc
1681 pprCondRegReg name size cond reg1 reg2
1692 pprSizeSizeRegReg :: LitString -> MachRep -> MachRep -> Reg -> Reg -> Doc
1693 pprSizeSizeRegReg name size1 size2 reg1 reg2
1706 pprSizeRegRegReg :: LitString -> MachRep -> Reg -> Reg -> Reg -> Doc
1707 pprSizeRegRegReg name size reg1 reg2 reg3
1709 pprMnemonic name size,
1717 pprSizeAddrReg :: LitString -> MachRep -> AddrMode -> Reg -> Doc
1718 pprSizeAddrReg name size op dst
1720 pprMnemonic name size,
1726 pprSizeRegAddr :: LitString -> MachRep -> Reg -> AddrMode -> Doc
1727 pprSizeRegAddr name size src op
1729 pprMnemonic name size,
1735 pprShift :: LitString -> MachRep -> Operand -> Operand -> Doc
1736 pprShift name size src dest
1738 pprMnemonic name size,
1739 pprOperand I8 src, -- src is 8-bit sized
1741 pprOperand size dest
1744 pprSizeOpOpCoerce :: LitString -> MachRep -> MachRep -> Operand -> Operand -> Doc
1745 pprSizeOpOpCoerce name size1 size2 op1 op2
1746 = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
1747 pprOperand size1 op1,
1749 pprOperand size2 op2
1752 pprCondInstr :: LitString -> Cond -> Doc -> Doc
1753 pprCondInstr name cond arg
1754 = hcat [ char '\t', ptext name, pprCond cond, space, arg]
1756 #endif /* i386_TARGET_ARCH */
1759 -- ------------------------------------------------------------------------------- pprInstr for a SPARC
1761 #if sparc_TARGET_ARCH
1763 -- a clumsy hack for now, to handle possible double alignment problems
1765 -- even clumsier, to allow for RegReg regs that show when doing indexed
1766 -- reads (bytearrays).
1769 -- Translate to the following:
1772 -- ld [g1+4],%f(n+1)
1773 -- sub g1,g2,g1 -- to restore g1
1775 pprInstr (LD F64 (AddrRegReg g1 g2) reg)
1777 hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1778 hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg],
1779 hcat [pp_ld_lbracket, pprReg g1, ptext SLIT("+4]"), comma, pprReg (fPair reg)],
1780 hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1785 -- ld [addr+4],%f(n+1)
1786 pprInstr (LD F64 addr reg) | isJust off_addr
1788 hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
1789 hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg (fPair reg)]
1792 off_addr = addrOffset addr 4
1793 addr2 = case off_addr of Just x -> x
1796 pprInstr (LD size addr reg)
1807 -- The same clumsy hack as above
1809 -- Translate to the following:
1812 -- st %f(n+1),[g1+4]
1813 -- sub g1,g2,g1 -- to restore g1
1814 pprInstr (ST F64 reg (AddrRegReg g1 g2))
1816 hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1817 hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1819 hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1820 pprReg g1, ptext SLIT("+4]")],
1821 hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1826 -- st %f(n+1),[addr+4]
1827 pprInstr (ST F64 reg addr) | isJust off_addr
1829 hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1830 pprAddr addr, rbrack],
1831 hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1832 pprAddr addr2, rbrack]
1835 off_addr = addrOffset addr 4
1836 addr2 = case off_addr of Just x -> x
1838 -- no distinction is made between signed and unsigned bytes on stores for the
1839 -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
1840 -- so we call a special-purpose pprSize for ST..
1842 pprInstr (ST size reg addr)
1853 pprInstr (ADD x cc reg1 ri reg2)
1854 | not x && not cc && riZero ri
1855 = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1857 = pprRegRIReg (if x then SLIT("addx") else SLIT("add")) cc reg1 ri reg2
1859 pprInstr (SUB x cc reg1 ri reg2)
1860 | not x && cc && reg2 == g0
1861 = hcat [ ptext SLIT("\tcmp\t"), pprReg reg1, comma, pprRI ri ]
1862 | not x && not cc && riZero ri
1863 = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1865 = pprRegRIReg (if x then SLIT("subx") else SLIT("sub")) cc reg1 ri reg2
1867 pprInstr (AND b reg1 ri reg2) = pprRegRIReg SLIT("and") b reg1 ri reg2
1868 pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg SLIT("andn") b reg1 ri reg2
1870 pprInstr (OR b reg1 ri reg2)
1871 | not b && reg1 == g0
1872 = let doit = hcat [ ptext SLIT("\tmov\t"), pprRI ri, comma, pprReg reg2 ]
1874 RIReg rrr | rrr == reg2 -> empty
1877 = pprRegRIReg SLIT("or") b reg1 ri reg2
1879 pprInstr (ORN b reg1 ri reg2) = pprRegRIReg SLIT("orn") b reg1 ri reg2
1881 pprInstr (XOR b reg1 ri reg2) = pprRegRIReg SLIT("xor") b reg1 ri reg2
1882 pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg SLIT("xnor") b reg1 ri reg2
1884 pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") False reg1 ri reg2
1885 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") False reg1 ri reg2
1886 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") False reg1 ri reg2
1888 pprInstr (RDY rd) = ptext SLIT("\trd\t%y,") <> pprReg rd
1889 pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg SLIT("smul") b reg1 ri reg2
1890 pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg SLIT("umul") b reg1 ri reg2
1892 pprInstr (SETHI imm reg)
1894 ptext SLIT("\tsethi\t"),
1900 pprInstr NOP = ptext SLIT("\tnop")
1902 pprInstr (FABS F32 reg1 reg2) = pprSizeRegReg SLIT("fabs") F32 reg1 reg2
1903 pprInstr (FABS F64 reg1 reg2)
1904 = (<>) (pprSizeRegReg SLIT("fabs") F32 reg1 reg2)
1905 (if (reg1 == reg2) then empty
1906 else (<>) (char '\n')
1907 (pprSizeRegReg SLIT("fmov") F32 (fPair reg1) (fPair reg2)))
1909 pprInstr (FADD size reg1 reg2 reg3)
1910 = pprSizeRegRegReg SLIT("fadd") size reg1 reg2 reg3
1911 pprInstr (FCMP e size reg1 reg2)
1912 = pprSizeRegReg (if e then SLIT("fcmpe") else SLIT("fcmp")) size reg1 reg2
1913 pprInstr (FDIV size reg1 reg2 reg3)
1914 = pprSizeRegRegReg SLIT("fdiv") size reg1 reg2 reg3
1916 pprInstr (FMOV F32 reg1 reg2) = pprSizeRegReg SLIT("fmov") F32 reg1 reg2
1917 pprInstr (FMOV F64 reg1 reg2)
1918 = (<>) (pprSizeRegReg SLIT("fmov") F32 reg1 reg2)
1919 (if (reg1 == reg2) then empty
1920 else (<>) (char '\n')
1921 (pprSizeRegReg SLIT("fmov") F32 (fPair reg1) (fPair reg2)))
1923 pprInstr (FMUL size reg1 reg2 reg3)
1924 = pprSizeRegRegReg SLIT("fmul") size reg1 reg2 reg3
1926 pprInstr (FNEG F32 reg1 reg2) = pprSizeRegReg SLIT("fneg") F32 reg1 reg2
1927 pprInstr (FNEG F64 reg1 reg2)
1928 = (<>) (pprSizeRegReg SLIT("fneg") F32 reg1 reg2)
1929 (if (reg1 == reg2) then empty
1930 else (<>) (char '\n')
1931 (pprSizeRegReg SLIT("fmov") F32 (fPair reg1) (fPair reg2)))
1933 pprInstr (FSQRT size reg1 reg2) = pprSizeRegReg SLIT("fsqrt") size reg1 reg2
1934 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fsub") size reg1 reg2 reg3
1935 pprInstr (FxTOy size1 size2 reg1 reg2)
1942 F64 -> SLIT("dto")),
1947 F64 -> SLIT("d\t")),
1948 pprReg reg1, comma, pprReg reg2
1952 pprInstr (BI cond b lab)
1954 ptext SLIT("\tb"), pprCond cond,
1955 if b then pp_comma_a else empty,
1960 pprInstr (BF cond b lab)
1962 ptext SLIT("\tfb"), pprCond cond,
1963 if b then pp_comma_a else empty,
1968 pprInstr (JMP addr) = (<>) (ptext SLIT("\tjmp\t")) (pprAddr addr)
1970 pprInstr (CALL (Left imm) n _)
1971 = hcat [ ptext SLIT("\tcall\t"), pprImm imm, comma, int n ]
1972 pprInstr (CALL (Right reg) n _)
1973 = hcat [ ptext SLIT("\tcall\t"), pprReg reg, comma, int n ]
1976 pprRI (RIReg r) = pprReg r
1977 pprRI (RIImm r) = pprImm r
1979 pprSizeRegReg :: LitString -> MachRep -> Reg -> Reg -> Doc
1980 pprSizeRegReg name size reg1 reg2
1985 F32 -> ptext SLIT("s\t")
1986 F64 -> ptext SLIT("d\t")),
1992 pprSizeRegRegReg :: LitString -> MachRep -> Reg -> Reg -> Reg -> Doc
1993 pprSizeRegRegReg name size reg1 reg2 reg3
1998 F32 -> ptext SLIT("s\t")
1999 F64 -> ptext SLIT("d\t")),
2007 pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
2008 pprRegRIReg name b reg1 ri reg2
2012 if b then ptext SLIT("cc\t") else char '\t',
2020 pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
2021 pprRIReg name b ri reg1
2025 if b then ptext SLIT("cc\t") else char '\t',
2031 pp_ld_lbracket = ptext SLIT("\tld\t[")
2032 pp_rbracket_comma = text "],"
2033 pp_comma_lbracket = text ",["
2034 pp_comma_a = text ",a"
2036 #endif /* sparc_TARGET_ARCH */
2039 -- -----------------------------------------------------------------------------
2040 -- pprInstr for PowerPC
2042 #if powerpc_TARGET_ARCH
2043 pprInstr (LD sz reg addr) = hcat [
2052 case addr of AddrRegImm _ _ -> empty
2053 AddrRegReg _ _ -> char 'x',
2059 pprInstr (LA sz reg addr) = hcat [
2068 case addr of AddrRegImm _ _ -> empty
2069 AddrRegReg _ _ -> char 'x',
2075 pprInstr (ST sz reg addr) = hcat [
2079 case addr of AddrRegImm _ _ -> empty
2080 AddrRegReg _ _ -> char 'x',
2086 pprInstr (STU sz reg addr) = hcat [
2091 case addr of AddrRegImm _ _ -> empty
2092 AddrRegReg _ _ -> char 'x',
2097 pprInstr (LIS reg imm) = hcat [
2105 pprInstr (LI reg imm) = hcat [
2113 pprInstr (MR reg1 reg2)
2114 | reg1 == reg2 = empty
2115 | otherwise = hcat [
2117 case regClass reg1 of
2118 RcInteger -> ptext SLIT("mr")
2119 _ -> ptext SLIT("fmr"),
2125 pprInstr (CMP sz reg ri) = hcat [
2141 pprInstr (CMPL sz reg ri) = hcat [
2157 pprInstr (BCC cond (BlockId id)) = hcat [
2164 where lbl = mkAsmTempLabel id
2166 pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
2173 pprInstr (MTCTR reg) = hcat [
2175 ptext SLIT("mtctr"),
2179 pprInstr (BCTR _) = hcat [
2183 pprInstr (BL lbl _) = hcat [
2184 ptext SLIT("\tbl\t"),
2187 pprInstr (BCTRL _) = hcat [
2191 pprInstr (ADD reg1 reg2 ri) = pprLogic SLIT("add") reg1 reg2 ri
2192 pprInstr (ADDIS reg1 reg2 imm) = hcat [
2194 ptext SLIT("addis"),
2203 pprInstr (ADDC reg1 reg2 reg3) = pprLogic SLIT("addc") reg1 reg2 (RIReg reg3)
2204 pprInstr (ADDE reg1 reg2 reg3) = pprLogic SLIT("adde") reg1 reg2 (RIReg reg3)
2205 pprInstr (SUBF reg1 reg2 reg3) = pprLogic SLIT("subf") reg1 reg2 (RIReg reg3)
2206 pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic SLIT("mullw") reg1 reg2 ri
2207 pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic SLIT("mull") reg1 reg2 ri
2208 pprInstr (DIVW reg1 reg2 reg3) = pprLogic SLIT("divw") reg1 reg2 (RIReg reg3)
2209 pprInstr (DIVWU reg1 reg2 reg3) = pprLogic SLIT("divwu") reg1 reg2 (RIReg reg3)
2211 pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
2212 hcat [ ptext SLIT("\tmullwo\t"), pprReg reg1, ptext SLIT(", "),
2213 pprReg reg2, ptext SLIT(", "),
2215 hcat [ ptext SLIT("\tmfxer\t"), pprReg reg1 ],
2216 hcat [ ptext SLIT("\trlwinm\t"), pprReg reg1, ptext SLIT(", "),
2217 pprReg reg1, ptext SLIT(", "),
2218 ptext SLIT("2, 31, 31") ]
2221 -- for some reason, "andi" doesn't exist.
2222 -- we'll use "andi." instead.
2223 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
2225 ptext SLIT("andi."),
2233 pprInstr (AND reg1 reg2 ri) = pprLogic SLIT("and") reg1 reg2 ri
2235 pprInstr (OR reg1 reg2 ri) = pprLogic SLIT("or") reg1 reg2 ri
2236 pprInstr (XOR reg1 reg2 ri) = pprLogic SLIT("xor") reg1 reg2 ri
2238 pprInstr (XORIS reg1 reg2 imm) = hcat [
2240 ptext SLIT("xoris"),
2249 pprInstr (EXTS sz reg1 reg2) = hcat [
2259 pprInstr (NEG reg1 reg2) = pprUnary SLIT("neg") reg1 reg2
2260 pprInstr (NOT reg1 reg2) = pprUnary SLIT("not") reg1 reg2
2262 pprInstr (SLW reg1 reg2 ri) = pprLogic SLIT("slw") reg1 reg2 (limitShiftRI ri)
2263 pprInstr (SRW reg1 reg2 ri) = pprLogic SLIT("srw") reg1 reg2 (limitShiftRI ri)
2264 pprInstr (SRAW reg1 reg2 ri) = pprLogic SLIT("sraw") reg1 reg2 (limitShiftRI ri)
2265 pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
2266 ptext SLIT("\trlwinm\t"),
2278 pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF SLIT("fadd") sz reg1 reg2 reg3
2279 pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF SLIT("fsub") sz reg1 reg2 reg3
2280 pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF SLIT("fmul") sz reg1 reg2 reg3
2281 pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF SLIT("fdiv") sz reg1 reg2 reg3
2282 pprInstr (FNEG reg1 reg2) = pprUnary SLIT("fneg") reg1 reg2
2284 pprInstr (FCMP reg1 reg2) = hcat [
2286 ptext SLIT("fcmpu\tcr0, "),
2287 -- Note: we're using fcmpu, not fcmpo
2288 -- The difference is with fcmpo, compare with NaN is an invalid operation.
2289 -- We don't handle invalid fp ops, so we don't care
2295 pprInstr (FCTIWZ reg1 reg2) = pprUnary SLIT("fctiwz") reg1 reg2
2296 pprInstr (FRSP reg1 reg2) = pprUnary SLIT("frsp") reg1 reg2
2298 pprInstr (CRNOR dst src1 src2) = hcat [
2299 ptext SLIT("\tcrnor\t"),
2307 pprInstr (MFCR reg) = hcat [
2314 pprInstr (MFLR reg) = hcat [
2321 pprInstr (FETCHPC reg) = vcat [
2322 ptext SLIT("\tbcl\t20,31,1f"),
2323 hcat [ ptext SLIT("1:\tmflr\t"), pprReg reg ]
2326 pprInstr _ = panic "pprInstr (ppc)"
2328 pprLogic op reg1 reg2 ri = hcat [
2333 RIImm _ -> char 'i',
2342 pprUnary op reg1 reg2 = hcat [
2351 pprBinaryF op sz reg1 reg2 reg3 = hcat [
2364 pprRI (RIReg r) = pprReg r
2365 pprRI (RIImm r) = pprImm r
2367 pprFSize F64 = empty
2368 pprFSize F32 = char 's'
2370 -- limit immediate argument for shift instruction to range 0..32
2371 -- (yes, the maximum is really 32, not 31)
2372 limitShiftRI :: RI -> RI
2373 limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32)
2376 #endif /* powerpc_TARGET_ARCH */
2379 -- -----------------------------------------------------------------------------
2380 -- Converting floating-point literals to integrals for printing
2382 #if __GLASGOW_HASKELL__ >= 504
2383 newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
2384 newFloatArray = newArray_
2386 newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
2387 newDoubleArray = newArray_
2389 castFloatToCharArray :: STUArray s Int Float -> ST s (STUArray s Int Word8)
2390 castFloatToCharArray = castSTUArray
2392 castDoubleToCharArray :: STUArray s Int Double -> ST s (STUArray s Int Word8)
2393 castDoubleToCharArray = castSTUArray
2395 writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
2396 writeFloatArray = writeArray
2398 writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
2399 writeDoubleArray = writeArray
2401 readCharArray :: STUArray s Int Word8 -> Int -> ST s Char
2402 readCharArray arr i = do
2403 w <- readArray arr i
2404 return $! (chr (fromIntegral w))
2408 castFloatToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2409 castFloatToCharArray = return
2411 castDoubleToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2414 castDoubleToCharArray = return
2418 -- floatToBytes and doubleToBytes convert to the host's byte
2419 -- order. Providing that we're not cross-compiling for a
2420 -- target with the opposite endianness, this should work ok
2423 -- ToDo: this stuff is very similar to the shenanigans in PprAbs,
2424 -- could they be merged?
2426 floatToBytes :: Float -> [Int]
2429 arr <- newFloatArray ((0::Int),3)
2430 writeFloatArray arr 0 f
2431 arr <- castFloatToCharArray arr
2432 i0 <- readCharArray arr 0
2433 i1 <- readCharArray arr 1
2434 i2 <- readCharArray arr 2
2435 i3 <- readCharArray arr 3
2436 return (map ord [i0,i1,i2,i3])
2439 doubleToBytes :: Double -> [Int]
2442 arr <- newDoubleArray ((0::Int),7)
2443 writeDoubleArray arr 0 d
2444 arr <- castDoubleToCharArray arr
2445 i0 <- readCharArray arr 0
2446 i1 <- readCharArray arr 1
2447 i2 <- readCharArray arr 2
2448 i3 <- readCharArray arr 3
2449 i4 <- readCharArray arr 4
2450 i5 <- readCharArray arr 5
2451 i6 <- readCharArray arr 6
2452 i7 <- readCharArray arr 7
2453 return (map ord [i0,i1,i2,i3,i4,i5,i6,i7])