2 -- The above warning supression flag is a temporary kludge.
3 -- While working on this module you are encouraged to remove it and fix
4 -- any warnings in the module. See
5 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
8 -----------------------------------------------------------------------------
10 -- Pretty-printing assembly language
12 -- (c) The University of Glasgow 1993-2005
14 -----------------------------------------------------------------------------
16 -- We start with the @pprXXX@s with some cross-platform commonality
17 -- (e.g., 'pprReg'); we conclude with the no-commonality monster,
20 #include "nativeGen/NCG.h"
23 pprNatCmmTop, pprBasicBlock, pprSectionHeader, pprData,
24 pprInstr, pprSize, pprUserReg
27 #include "HsVersions.h"
31 import MachRegs -- may differ per-platform
34 import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel,
35 labelDynamic, mkAsmTempLabel, entryLblToInfoLbl )
36 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
37 import CLabel ( mkDeadStripPreventer )
40 import Panic ( panic )
41 import Unique ( pprUnique )
44 import qualified Outputable
45 import Outputable ( Outputable, pprPanic, ppr, docToSDoc)
48 import Data.Word ( Word8 )
49 import Control.Monad.ST
50 import Data.Char ( chr, ord )
51 import Data.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 _ (ListGraph [])) = pprLabel lbl
72 pprNatCmmTop (CmmProc info lbl params (ListGraph blocks)) =
73 pprSectionHeader Text $$
74 (if null info then -- blocks guaranteed not null, so label needed
77 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
78 pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
81 vcat (map pprData info) $$
82 pprLabel (entryLblToInfoLbl lbl)
84 vcat (map pprBasicBlock blocks)
85 -- above: Even the first block gets a label, because with branch-chain
86 -- elimination, it might be the target of a goto.
87 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
88 -- If we are using the .subsections_via_symbols directive
89 -- (available on recent versions of Darwin),
90 -- we have to make sure that there is some kind of reference
91 -- from the entry code to a label on the _top_ of of the info table,
92 -- so that the linker will not think it is unreferenced and dead-strip
93 -- it. That's why the label is called a DeadStripPreventer (_dsp).
96 <+> pprCLabel_asm (entryLblToInfoLbl lbl)
98 <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
103 pprBasicBlock :: NatBasicBlock -> Doc
104 pprBasicBlock (BasicBlock (BlockId id) instrs) =
105 pprLabel (mkAsmTempLabel id) $$
106 vcat (map pprInstr instrs)
108 -- -----------------------------------------------------------------------------
109 -- pprReg: print a 'Reg'
111 -- For x86, the way we print a register name depends
112 -- on which bit of it we care about. Yurgh.
114 pprUserReg :: Reg -> Doc
115 pprUserReg = pprReg IF_ARCH_i386(II32,) IF_ARCH_x86_64(II64,)
117 pprReg :: IF_ARCH_i386(Size ->,) IF_ARCH_x86_64(Size ->,) Reg -> Doc
119 pprReg IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) r
121 RealReg i -> ppr_reg_no IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) i
122 VirtualRegI u -> text "%vI_" <> asmSDoc (pprUnique u)
123 VirtualRegHi u -> text "%vHi_" <> asmSDoc (pprUnique u)
124 VirtualRegF u -> text "%vF_" <> asmSDoc (pprUnique u)
125 VirtualRegD u -> text "%vD_" <> asmSDoc (pprUnique u)
127 #if alpha_TARGET_ARCH
128 ppr_reg_no :: Int -> Doc
131 0 -> sLit "$0"; 1 -> sLit "$1";
132 2 -> sLit "$2"; 3 -> sLit "$3";
133 4 -> sLit "$4"; 5 -> sLit "$5";
134 6 -> sLit "$6"; 7 -> sLit "$7";
135 8 -> sLit "$8"; 9 -> sLit "$9";
136 10 -> sLit "$10"; 11 -> sLit "$11";
137 12 -> sLit "$12"; 13 -> sLit "$13";
138 14 -> sLit "$14"; 15 -> sLit "$15";
139 16 -> sLit "$16"; 17 -> sLit "$17";
140 18 -> sLit "$18"; 19 -> sLit "$19";
141 20 -> sLit "$20"; 21 -> sLit "$21";
142 22 -> sLit "$22"; 23 -> sLit "$23";
143 24 -> sLit "$24"; 25 -> sLit "$25";
144 26 -> sLit "$26"; 27 -> sLit "$27";
145 28 -> sLit "$28"; 29 -> sLit "$29";
146 30 -> sLit "$30"; 31 -> sLit "$31";
147 32 -> sLit "$f0"; 33 -> sLit "$f1";
148 34 -> sLit "$f2"; 35 -> sLit "$f3";
149 36 -> sLit "$f4"; 37 -> sLit "$f5";
150 38 -> sLit "$f6"; 39 -> sLit "$f7";
151 40 -> sLit "$f8"; 41 -> sLit "$f9";
152 42 -> sLit "$f10"; 43 -> sLit "$f11";
153 44 -> sLit "$f12"; 45 -> sLit "$f13";
154 46 -> sLit "$f14"; 47 -> sLit "$f15";
155 48 -> sLit "$f16"; 49 -> sLit "$f17";
156 50 -> sLit "$f18"; 51 -> sLit "$f19";
157 52 -> sLit "$f20"; 53 -> sLit "$f21";
158 54 -> sLit "$f22"; 55 -> sLit "$f23";
159 56 -> sLit "$f24"; 57 -> sLit "$f25";
160 58 -> sLit "$f26"; 59 -> sLit "$f27";
161 60 -> sLit "$f28"; 61 -> sLit "$f29";
162 62 -> sLit "$f30"; 63 -> sLit "$f31";
163 _ -> sLit "very naughty alpha register"
167 ppr_reg_no :: Size -> Int -> Doc
168 ppr_reg_no II8 = ppr_reg_byte
169 ppr_reg_no II16 = ppr_reg_word
170 ppr_reg_no _ = ppr_reg_long
172 ppr_reg_byte i = ptext
174 0 -> sLit "%al"; 1 -> sLit "%bl";
175 2 -> sLit "%cl"; 3 -> sLit "%dl";
176 _ -> sLit "very naughty I386 byte register"
179 ppr_reg_word i = ptext
181 0 -> sLit "%ax"; 1 -> sLit "%bx";
182 2 -> sLit "%cx"; 3 -> sLit "%dx";
183 4 -> sLit "%si"; 5 -> sLit "%di";
184 6 -> sLit "%bp"; 7 -> sLit "%sp";
185 _ -> sLit "very naughty I386 word register"
188 ppr_reg_long i = ptext
190 0 -> sLit "%eax"; 1 -> sLit "%ebx";
191 2 -> sLit "%ecx"; 3 -> sLit "%edx";
192 4 -> sLit "%esi"; 5 -> sLit "%edi";
193 6 -> sLit "%ebp"; 7 -> sLit "%esp";
194 8 -> sLit "%fake0"; 9 -> sLit "%fake1";
195 10 -> sLit "%fake2"; 11 -> sLit "%fake3";
196 12 -> sLit "%fake4"; 13 -> sLit "%fake5";
197 _ -> sLit "very naughty I386 register"
201 #if x86_64_TARGET_ARCH
202 ppr_reg_no :: Size -> Int -> Doc
203 ppr_reg_no II8 = ppr_reg_byte
204 ppr_reg_no II16 = ppr_reg_word
205 ppr_reg_no II32 = ppr_reg_long
206 ppr_reg_no _ = ppr_reg_quad
208 ppr_reg_byte i = ptext
210 0 -> sLit "%al"; 1 -> sLit "%bl";
211 2 -> sLit "%cl"; 3 -> sLit "%dl";
212 4 -> sLit "%sil"; 5 -> sLit "%dil"; -- new 8-bit regs!
213 6 -> sLit "%bpl"; 7 -> sLit "%spl";
214 8 -> sLit "%r8b"; 9 -> sLit "%r9b";
215 10 -> sLit "%r10b"; 11 -> sLit "%r11b";
216 12 -> sLit "%r12b"; 13 -> sLit "%r13b";
217 14 -> sLit "%r14b"; 15 -> sLit "%r15b";
218 _ -> sLit "very naughty x86_64 byte register"
221 ppr_reg_word i = ptext
223 0 -> sLit "%ax"; 1 -> sLit "%bx";
224 2 -> sLit "%cx"; 3 -> sLit "%dx";
225 4 -> sLit "%si"; 5 -> sLit "%di";
226 6 -> sLit "%bp"; 7 -> sLit "%sp";
227 8 -> sLit "%r8w"; 9 -> sLit "%r9w";
228 10 -> sLit "%r10w"; 11 -> sLit "%r11w";
229 12 -> sLit "%r12w"; 13 -> sLit "%r13w";
230 14 -> sLit "%r14w"; 15 -> sLit "%r15w";
231 _ -> sLit "very naughty x86_64 word register"
234 ppr_reg_long i = ptext
236 0 -> sLit "%eax"; 1 -> sLit "%ebx";
237 2 -> sLit "%ecx"; 3 -> sLit "%edx";
238 4 -> sLit "%esi"; 5 -> sLit "%edi";
239 6 -> sLit "%ebp"; 7 -> sLit "%esp";
240 8 -> sLit "%r8d"; 9 -> sLit "%r9d";
241 10 -> sLit "%r10d"; 11 -> sLit "%r11d";
242 12 -> sLit "%r12d"; 13 -> sLit "%r13d";
243 14 -> sLit "%r14d"; 15 -> sLit "%r15d";
244 _ -> sLit "very naughty x86_64 register"
247 ppr_reg_quad i = ptext
249 0 -> sLit "%rax"; 1 -> sLit "%rbx";
250 2 -> sLit "%rcx"; 3 -> sLit "%rdx";
251 4 -> sLit "%rsi"; 5 -> sLit "%rdi";
252 6 -> sLit "%rbp"; 7 -> sLit "%rsp";
253 8 -> sLit "%r8"; 9 -> sLit "%r9";
254 10 -> sLit "%r10"; 11 -> sLit "%r11";
255 12 -> sLit "%r12"; 13 -> sLit "%r13";
256 14 -> sLit "%r14"; 15 -> sLit "%r15";
257 16 -> sLit "%xmm0"; 17 -> sLit "%xmm1";
258 18 -> sLit "%xmm2"; 19 -> sLit "%xmm3";
259 20 -> sLit "%xmm4"; 21 -> sLit "%xmm5";
260 22 -> sLit "%xmm6"; 23 -> sLit "%xmm7";
261 24 -> sLit "%xmm8"; 25 -> sLit "%xmm9";
262 26 -> sLit "%xmm10"; 27 -> sLit "%xmm11";
263 28 -> sLit "%xmm12"; 29 -> sLit "%xmm13";
264 30 -> sLit "%xmm14"; 31 -> sLit "%xmm15";
265 _ -> sLit "very naughty x86_64 register"
269 #if sparc_TARGET_ARCH
270 ppr_reg_no :: Int -> Doc
273 0 -> sLit "%g0"; 1 -> sLit "%g1";
274 2 -> sLit "%g2"; 3 -> sLit "%g3";
275 4 -> sLit "%g4"; 5 -> sLit "%g5";
276 6 -> sLit "%g6"; 7 -> sLit "%g7";
277 8 -> sLit "%o0"; 9 -> sLit "%o1";
278 10 -> sLit "%o2"; 11 -> sLit "%o3";
279 12 -> sLit "%o4"; 13 -> sLit "%o5";
280 14 -> sLit "%o6"; 15 -> sLit "%o7";
281 16 -> sLit "%l0"; 17 -> sLit "%l1";
282 18 -> sLit "%l2"; 19 -> sLit "%l3";
283 20 -> sLit "%l4"; 21 -> sLit "%l5";
284 22 -> sLit "%l6"; 23 -> sLit "%l7";
285 24 -> sLit "%i0"; 25 -> sLit "%i1";
286 26 -> sLit "%i2"; 27 -> sLit "%i3";
287 28 -> sLit "%i4"; 29 -> sLit "%i5";
288 30 -> sLit "%i6"; 31 -> sLit "%i7";
289 32 -> sLit "%f0"; 33 -> sLit "%f1";
290 34 -> sLit "%f2"; 35 -> sLit "%f3";
291 36 -> sLit "%f4"; 37 -> sLit "%f5";
292 38 -> sLit "%f6"; 39 -> sLit "%f7";
293 40 -> sLit "%f8"; 41 -> sLit "%f9";
294 42 -> sLit "%f10"; 43 -> sLit "%f11";
295 44 -> sLit "%f12"; 45 -> sLit "%f13";
296 46 -> sLit "%f14"; 47 -> sLit "%f15";
297 48 -> sLit "%f16"; 49 -> sLit "%f17";
298 50 -> sLit "%f18"; 51 -> sLit "%f19";
299 52 -> sLit "%f20"; 53 -> sLit "%f21";
300 54 -> sLit "%f22"; 55 -> sLit "%f23";
301 56 -> sLit "%f24"; 57 -> sLit "%f25";
302 58 -> sLit "%f26"; 59 -> sLit "%f27";
303 60 -> sLit "%f28"; 61 -> sLit "%f29";
304 62 -> sLit "%f30"; 63 -> sLit "%f31";
305 _ -> sLit "very naughty sparc register"
308 #if powerpc_TARGET_ARCH
310 ppr_reg_no :: Int -> Doc
313 0 -> sLit "r0"; 1 -> sLit "r1";
314 2 -> sLit "r2"; 3 -> sLit "r3";
315 4 -> sLit "r4"; 5 -> sLit "r5";
316 6 -> sLit "r6"; 7 -> sLit "r7";
317 8 -> sLit "r8"; 9 -> sLit "r9";
318 10 -> sLit "r10"; 11 -> sLit "r11";
319 12 -> sLit "r12"; 13 -> sLit "r13";
320 14 -> sLit "r14"; 15 -> sLit "r15";
321 16 -> sLit "r16"; 17 -> sLit "r17";
322 18 -> sLit "r18"; 19 -> sLit "r19";
323 20 -> sLit "r20"; 21 -> sLit "r21";
324 22 -> sLit "r22"; 23 -> sLit "r23";
325 24 -> sLit "r24"; 25 -> sLit "r25";
326 26 -> sLit "r26"; 27 -> sLit "r27";
327 28 -> sLit "r28"; 29 -> sLit "r29";
328 30 -> sLit "r30"; 31 -> sLit "r31";
329 32 -> sLit "f0"; 33 -> sLit "f1";
330 34 -> sLit "f2"; 35 -> sLit "f3";
331 36 -> sLit "f4"; 37 -> sLit "f5";
332 38 -> sLit "f6"; 39 -> sLit "f7";
333 40 -> sLit "f8"; 41 -> sLit "f9";
334 42 -> sLit "f10"; 43 -> sLit "f11";
335 44 -> sLit "f12"; 45 -> sLit "f13";
336 46 -> sLit "f14"; 47 -> sLit "f15";
337 48 -> sLit "f16"; 49 -> sLit "f17";
338 50 -> sLit "f18"; 51 -> sLit "f19";
339 52 -> sLit "f20"; 53 -> sLit "f21";
340 54 -> sLit "f22"; 55 -> sLit "f23";
341 56 -> sLit "f24"; 57 -> sLit "f25";
342 58 -> sLit "f26"; 59 -> sLit "f27";
343 60 -> sLit "f28"; 61 -> sLit "f29";
344 62 -> sLit "f30"; 63 -> sLit "f31";
345 _ -> sLit "very naughty powerpc register"
348 ppr_reg_no :: Int -> Doc
349 ppr_reg_no i | i <= 31 = int i -- GPRs
350 | i <= 63 = int (i-32) -- FPRs
351 | otherwise = ptext (sLit "very naughty powerpc register")
356 -- -----------------------------------------------------------------------------
358 -- Used for instruction suffixes.
359 -- eg LD is 32bit on sparc, but LDD is 64 bit.
362 #if powerpc_TARGET_ARCH || i386_TARGET_ARCH || x86_64_TARGET_ARCH || sparc_TARGET_ARCH
363 pprSize :: Size -> Doc
365 pprSize :: Size -> Doc
368 pprSize x = ptext (case x of
369 #if alpha_TARGET_ARCH
372 -- W -> sLit "w" UNUSED
373 -- Wu -> sLit "wu" UNUSED
376 -- FF -> sLit "f" UNUSED
377 -- DF -> sLit "d" UNUSED
378 -- GF -> sLit "g" UNUSED
379 -- SF -> sLit "s" UNUSED
382 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
393 #if x86_64_TARGET_ARCH
394 FF32 -> sLit "ss" -- "scalar single-precision float" (SSE2)
395 FF64 -> sLit "sd" -- "scalar double-precision float" (SSE2)
397 #if sparc_TARGET_ARCH
405 pprStSize :: Size -> 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 wordSize 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(IF_OS_darwin(sLit ".text\n.align 3",
627 sLit ".text\n\t.align 8")
628 ,IF_ARCH_powerpc(sLit ".text\n.align 2"
630 pprSectionHeader Data
632 (IF_ARCH_alpha(sLit "\t.data\n\t.align 3"
633 ,IF_ARCH_sparc(sLit ".data\n\t.align 8" {-<8 will break double constants -}
634 ,IF_ARCH_i386(IF_OS_darwin(sLit ".data\n\t.align 2",
635 sLit ".data\n\t.align 4")
636 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".data\n.align 3",
637 sLit ".data\n\t.align 8")
638 ,IF_ARCH_powerpc(sLit ".data\n.align 2"
640 pprSectionHeader ReadOnlyData
642 (IF_ARCH_alpha(sLit "\t.data\n\t.align 3"
643 ,IF_ARCH_sparc(sLit ".text\n\t.align 8" {-<8 will break double constants -}
644 ,IF_ARCH_i386(IF_OS_darwin(sLit ".const\n.align 2",
645 sLit ".section .rodata\n\t.align 4")
646 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".const\n.align 3",
647 sLit ".section .rodata\n\t.align 8")
648 ,IF_ARCH_powerpc(IF_OS_darwin(sLit ".const\n.align 2",
649 sLit ".section .rodata\n\t.align 2")
651 pprSectionHeader RelocatableReadOnlyData
653 (IF_ARCH_alpha(sLit "\t.data\n\t.align 3"
654 ,IF_ARCH_sparc(sLit ".text\n\t.align 8" {-<8 will break double constants -}
655 ,IF_ARCH_i386(IF_OS_darwin(sLit ".const_data\n.align 2",
656 sLit ".section .data\n\t.align 4")
657 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".const_data\n.align 3",
658 sLit ".section .data\n\t.align 8")
659 ,IF_ARCH_powerpc(IF_OS_darwin(sLit ".const_data\n.align 2",
660 sLit ".data\n\t.align 2")
662 pprSectionHeader UninitialisedData
664 (IF_ARCH_alpha(sLit "\t.bss\n\t.align 3"
665 ,IF_ARCH_sparc(sLit ".bss\n\t.align 8" {-<8 will break double constants -}
666 ,IF_ARCH_i386(IF_OS_darwin(sLit ".data\n\t.align 2",
667 sLit ".section .bss\n\t.align 4")
668 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".data\n\t.align 3",
669 sLit ".section .bss\n\t.align 8")
670 ,IF_ARCH_powerpc(IF_OS_darwin(sLit ".const_data\n.align 2",
671 sLit ".section .bss\n\t.align 2")
673 pprSectionHeader ReadOnlyData16
675 (IF_ARCH_alpha(sLit "\t.data\n\t.align 4"
676 ,IF_ARCH_sparc(sLit ".data\n\t.align 16"
677 ,IF_ARCH_i386(IF_OS_darwin(sLit ".const\n.align 4",
678 sLit ".section .rodata\n\t.align 16")
679 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".const\n.align 4",
680 sLit ".section .rodata.cst16\n\t.align 16")
681 ,IF_ARCH_powerpc(IF_OS_darwin(sLit ".const\n.align 4",
682 sLit ".section .rodata\n\t.align 4")
685 pprSectionHeader (OtherSection sec)
686 = panic "PprMach.pprSectionHeader: unknown section"
688 pprData :: CmmStatic -> Doc
689 pprData (CmmAlign bytes) = pprAlign bytes
690 pprData (CmmDataLabel lbl) = pprLabel lbl
691 pprData (CmmString str) = pprASCII str
692 pprData (CmmUninitialised bytes) = ptext (sLit ".space ") <> int bytes
693 pprData (CmmStaticLit lit) = pprDataItem lit
695 pprGloblDecl :: CLabel -> Doc
697 | not (externallyVisibleCLabel lbl) = empty
698 | otherwise = ptext IF_ARCH_sparc((sLit ".global "),
702 pprTypeAndSizeDecl :: CLabel -> Doc
703 pprTypeAndSizeDecl lbl
705 | not (externallyVisibleCLabel lbl) = empty
706 | otherwise = ptext (sLit ".type ") <>
707 pprCLabel_asm lbl <> ptext (sLit ", @object")
712 pprLabel :: CLabel -> Doc
713 pprLabel lbl = pprGloblDecl lbl $$ pprTypeAndSizeDecl lbl $$ (pprCLabel_asm lbl <> char ':')
717 = vcat (map do1 str) $$ do1 0
720 do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w)
723 IF_ARCH_alpha(ptext (sLit ".align ") <> int pow2,
724 IF_ARCH_i386(ptext (sLit ".align ") <> int IF_OS_darwin(pow2,bytes),
725 IF_ARCH_x86_64(ptext (sLit ".align ") <> int IF_OS_darwin(pow2,bytes),
726 IF_ARCH_sparc(ptext (sLit ".align ") <> int bytes,
727 IF_ARCH_powerpc(ptext (sLit ".align ") <> int pow2,)))))
731 log2 :: Int -> Int -- cache the common ones
736 log2 n = 1 + log2 (n `quot` 2)
739 pprDataItem :: CmmLit -> Doc
741 = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit)
745 -- These seem to be common:
746 ppr_item II8 x = [ptext (sLit "\t.byte\t") <> pprImm imm]
747 ppr_item II32 x = [ptext (sLit "\t.long\t") <> pprImm imm]
748 ppr_item FF32 (CmmFloat r _)
749 = let bs = floatToBytes (fromRational r)
750 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
751 ppr_item FF64 (CmmFloat r _)
752 = let bs = doubleToBytes (fromRational r)
753 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
755 #if sparc_TARGET_ARCH
756 -- copy n paste of x86 version
757 ppr_item II16 x = [ptext (sLit "\t.short\t") <> pprImm imm]
758 ppr_item II64 x = [ptext (sLit "\t.quad\t") <> pprImm imm]
760 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
761 ppr_item II16 x = [ptext (sLit "\t.word\t") <> pprImm imm]
763 #if i386_TARGET_ARCH && darwin_TARGET_OS
764 ppr_item II64 (CmmInt x _) =
765 [ptext (sLit "\t.long\t")
766 <> int (fromIntegral (fromIntegral x :: Word32)),
767 ptext (sLit "\t.long\t")
769 (fromIntegral (x `shiftR` 32) :: Word32))]
771 #if i386_TARGET_ARCH || (darwin_TARGET_OS && x86_64_TARGET_ARCH)
772 ppr_item II64 x = [ptext (sLit "\t.quad\t") <> pprImm imm]
774 #if x86_64_TARGET_ARCH && !darwin_TARGET_OS
775 -- x86_64: binutils can't handle the R_X86_64_PC64 relocation
776 -- type, which means we can't do pc-relative 64-bit addresses.
777 -- Fortunately we're assuming the small memory model, in which
778 -- all such offsets will fit into 32 bits, so we have to stick
779 -- to 32-bit offset fields and modify the RTS appropriately
781 -- See Note [x86-64-relative] in includes/InfoTables.h
784 | isRelativeReloc x =
785 [ptext (sLit "\t.long\t") <> pprImm imm,
786 ptext (sLit "\t.long\t0")]
788 [ptext (sLit "\t.quad\t") <> pprImm imm]
790 isRelativeReloc (CmmLabelDiffOff _ _ _) = True
791 isRelativeReloc _ = False
793 #if powerpc_TARGET_ARCH
794 ppr_item II16 x = [ptext (sLit "\t.short\t") <> pprImm imm]
795 ppr_item II64 (CmmInt x _) =
796 [ptext (sLit "\t.long\t")
798 (fromIntegral (x `shiftR` 32) :: Word32)),
799 ptext (sLit "\t.long\t")
800 <> int (fromIntegral (fromIntegral x :: Word32))]
803 -- fall through to rest of (machine-specific) pprInstr...
805 -- -----------------------------------------------------------------------------
806 -- pprInstr: print an 'Instr'
808 instance Outputable Instr where
809 ppr instr = Outputable.docToSDoc $ pprInstr instr
811 pprInstr :: Instr -> Doc
813 pprInstr (COMMENT s) = empty -- nuke 'em
816 = IF_ARCH_alpha( ((<>) (ptext (sLit "\t# ")) (ftext s))
817 ,IF_ARCH_sparc( ((<>) (ptext (sLit "# ")) (ftext s))
818 ,IF_ARCH_i386( ((<>) (ptext (sLit "# ")) (ftext s))
819 ,IF_ARCH_x86_64( ((<>) (ptext (sLit "# ")) (ftext s))
820 ,IF_ARCH_powerpc( IF_OS_linux(
821 ((<>) (ptext (sLit "# ")) (ftext s)),
822 ((<>) (ptext (sLit "; ")) (ftext s)))
826 = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
828 pprInstr (NEWBLOCK _)
829 = panic "PprMach.pprInstr: NEWBLOCK"
832 = panic "PprMach.pprInstr: LDATA"
834 -- -----------------------------------------------------------------------------
835 -- pprInstr for an Alpha
837 #if alpha_TARGET_ARCH
839 pprInstr (SPILL reg slot)
841 ptext (sLit "\tSPILL"),
845 ptext (sLit "SLOT") <> parens (int slot)]
847 pprInstr (RELOAD slot reg)
849 ptext (sLit "\tRELOAD"),
851 ptext (sLit "SLOT") <> parens (int slot),
855 pprInstr (LD size reg addr)
865 pprInstr (LDA reg addr)
867 ptext (sLit "\tlda\t"),
873 pprInstr (LDAH reg addr)
875 ptext (sLit "\tldah\t"),
881 pprInstr (LDGP reg addr)
883 ptext (sLit "\tldgp\t"),
889 pprInstr (LDI size reg imm)
891 ptext (sLit "\tldi"),
899 pprInstr (ST size reg addr)
911 ptext (sLit "\tclr\t"),
915 pprInstr (ABS size ri reg)
917 ptext (sLit "\tabs"),
925 pprInstr (NEG size ov ri reg)
927 ptext (sLit "\tneg"),
929 if ov then ptext (sLit "v\t") else char '\t',
935 pprInstr (ADD size ov reg1 ri reg2)
937 ptext (sLit "\tadd"),
939 if ov then ptext (sLit "v\t") else char '\t',
947 pprInstr (SADD size scale reg1 ri reg2)
949 ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
960 pprInstr (SUB size ov reg1 ri reg2)
962 ptext (sLit "\tsub"),
964 if ov then ptext (sLit "v\t") else char '\t',
972 pprInstr (SSUB size scale reg1 ri reg2)
974 ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
985 pprInstr (MUL size ov reg1 ri reg2)
987 ptext (sLit "\tmul"),
989 if ov then ptext (sLit "v\t") else char '\t',
997 pprInstr (DIV size uns reg1 ri reg2)
999 ptext (sLit "\tdiv"),
1001 if uns then ptext (sLit "u\t") else char '\t',
1009 pprInstr (REM size uns reg1 ri reg2)
1011 ptext (sLit "\trem"),
1013 if uns then ptext (sLit "u\t") else char '\t',
1021 pprInstr (NOT ri reg)
1023 ptext (sLit "\tnot"),
1030 pprInstr (AND reg1 ri reg2) = pprRegRIReg (sLit "and") reg1 ri reg2
1031 pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg (sLit "andnot") reg1 ri reg2
1032 pprInstr (OR reg1 ri reg2) = pprRegRIReg (sLit "or") reg1 ri reg2
1033 pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg (sLit "ornot") reg1 ri reg2
1034 pprInstr (XOR reg1 ri reg2) = pprRegRIReg (sLit "xor") reg1 ri reg2
1035 pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg (sLit "xornot") reg1 ri reg2
1037 pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") reg1 ri reg2
1038 pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") reg1 ri reg2
1039 pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") reg1 ri reg2
1041 pprInstr (ZAP reg1 ri reg2) = pprRegRIReg (sLit "zap") reg1 ri reg2
1042 pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg (sLit "zapnot") reg1 ri reg2
1044 pprInstr (NOP) = ptext (sLit "\tnop")
1046 pprInstr (CMP cond reg1 ri reg2)
1048 ptext (sLit "\tcmp"),
1060 ptext (sLit "\tfclr\t"),
1064 pprInstr (FABS reg1 reg2)
1066 ptext (sLit "\tfabs\t"),
1072 pprInstr (FNEG size reg1 reg2)
1074 ptext (sLit "\tneg"),
1082 pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "add") size reg1 reg2 reg3
1083 pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "div") size reg1 reg2 reg3
1084 pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "mul") size reg1 reg2 reg3
1085 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "sub") size reg1 reg2 reg3
1087 pprInstr (CVTxy size1 size2 reg1 reg2)
1089 ptext (sLit "\tcvt"),
1091 case size2 of {Q -> ptext (sLit "qc"); _ -> pprSize size2},
1098 pprInstr (FCMP size cond reg1 reg2 reg3)
1100 ptext (sLit "\tcmp"),
1111 pprInstr (FMOV reg1 reg2)
1113 ptext (sLit "\tfmov\t"),
1119 pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
1121 pprInstr (BI NEVER reg lab) = empty
1123 pprInstr (BI cond reg lab)
1133 pprInstr (BF cond reg lab)
1135 ptext (sLit "\tfb"),
1144 = (<>) (ptext (sLit "\tbr\t")) (pprImm lab)
1146 pprInstr (JMP reg addr hint)
1148 ptext (sLit "\tjmp\t"),
1156 pprInstr (BSR imm n)
1157 = (<>) (ptext (sLit "\tbsr\t")) (pprImm imm)
1159 pprInstr (JSR reg addr n)
1161 ptext (sLit "\tjsr\t"),
1167 pprInstr (FUNBEGIN clab)
1169 if (externallyVisibleCLabel clab) then
1170 hcat [ptext (sLit "\t.globl\t"), pp_lab, char '\n']
1173 ptext (sLit "\t.ent "),
1182 pp_lab = pprCLabel_asm clab
1184 -- NEVER use commas within those string literals, cpp will ruin your day
1185 pp_ldgp = hcat [ ptext (sLit ":\n\tldgp $29"), char ',', ptext (sLit "0($27)\n") ]
1186 pp_frame = hcat [ ptext (sLit "..ng:\n\t.frame $30"), char ',',
1187 ptext (sLit "4240"), char ',',
1188 ptext (sLit "$26"), char ',',
1189 ptext (sLit "0\n\t.prologue 1") ]
1191 pprInstr (FUNEND clab)
1192 = (<>) (ptext (sLit "\t.align 4\n\t.end ")) (pprCLabel_asm clab)
1195 Continue with Alpha-only printing bits and bobs:
1199 pprRI (RIReg r) = pprReg r
1200 pprRI (RIImm r) = pprImm r
1202 pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
1203 pprRegRIReg name reg1 ri reg2
1215 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1216 pprSizeRegRegReg name size reg1 reg2 reg3
1229 #endif /* alpha_TARGET_ARCH */
1232 -- -----------------------------------------------------------------------------
1233 -- pprInstr for an x86
1235 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1237 pprInstr (SPILL reg slot)
1239 ptext (sLit "\tSPILL"),
1243 ptext (sLit "SLOT") <> parens (int slot)]
1245 pprInstr (RELOAD slot reg)
1247 ptext (sLit "\tRELOAD"),
1249 ptext (sLit "SLOT") <> parens (int slot),
1253 pprInstr (MOV size src dst)
1254 = pprSizeOpOp (sLit "mov") size src dst
1256 pprInstr (MOVZxL II32 src dst) = pprSizeOpOp (sLit "mov") II32 src dst
1257 -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple
1258 -- movl. But we represent it as a MOVZxL instruction, because
1259 -- the reg alloc would tend to throw away a plain reg-to-reg
1260 -- move, and we still want it to do that.
1262 pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce (sLit "movz") sizes II32 src dst
1263 -- zero-extension only needs to extend to 32 bits: on x86_64,
1264 -- the remaining zero-extension to 64 bits is automatic, and the 32-bit
1265 -- instruction is shorter.
1267 pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce (sLit "movs") sizes wordSize src dst
1269 -- here we do some patching, since the physical registers are only set late
1270 -- in the code generation.
1271 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1273 = pprSizeOpOp (sLit "add") size (OpReg reg2) dst
1274 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1276 = pprSizeOpOp (sLit "add") size (OpReg reg1) dst
1277 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))
1279 = pprInstr (ADD size (OpImm displ) dst)
1280 pprInstr (LEA size src dst) = pprSizeOpOp (sLit "lea") size src dst
1282 pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
1283 = pprSizeOp (sLit "dec") size dst
1284 pprInstr (ADD size (OpImm (ImmInt 1)) dst)
1285 = pprSizeOp (sLit "inc") size dst
1286 pprInstr (ADD size src dst)
1287 = pprSizeOpOp (sLit "add") size src dst
1288 pprInstr (ADC size src dst)
1289 = pprSizeOpOp (sLit "adc") size src dst
1290 pprInstr (SUB size src dst) = pprSizeOpOp (sLit "sub") size src dst
1291 pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2
1293 {- A hack. The Intel documentation says that "The two and three
1294 operand forms [of IMUL] may also be used with unsigned operands
1295 because the lower half of the product is the same regardless if
1296 (sic) the operands are signed or unsigned. The CF and OF flags,
1297 however, cannot be used to determine if the upper half of the
1298 result is non-zero." So there.
1300 pprInstr (AND size src dst) = pprSizeOpOp (sLit "and") size src dst
1301 pprInstr (OR size src dst) = pprSizeOpOp (sLit "or") size src dst
1303 pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst
1304 pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst
1305 pprInstr (XOR size src dst) = pprSizeOpOp (sLit "xor") size src dst
1307 pprInstr (NOT size op) = pprSizeOp (sLit "not") size op
1308 pprInstr (NEGI size op) = pprSizeOp (sLit "neg") size op
1310 pprInstr (SHL size src dst) = pprShift (sLit "shl") size src dst
1311 pprInstr (SAR size src dst) = pprShift (sLit "sar") size src dst
1312 pprInstr (SHR size src dst) = pprShift (sLit "shr") size src dst
1314 pprInstr (BT size imm src) = pprSizeImmOp (sLit "bt") size imm src
1316 pprInstr (CMP size src dst)
1317 | is_float size = pprSizeOpOp (sLit "ucomi") size src dst -- SSE2
1318 | otherwise = pprSizeOpOp (sLit "cmp") size src dst
1320 -- This predicate is needed here and nowhere else
1321 is_float FF32 = True
1322 is_float FF64 = True
1323 is_float FF80 = True
1324 is_float other = False
1326 pprInstr (TEST size src dst) = pprSizeOpOp (sLit "test") size src dst
1327 pprInstr (PUSH size op) = pprSizeOp (sLit "push") size op
1328 pprInstr (POP size op) = pprSizeOp (sLit "pop") size op
1330 -- both unused (SDM):
1331 -- pprInstr PUSHA = ptext (sLit "\tpushal")
1332 -- pprInstr POPA = ptext (sLit "\tpopal")
1334 pprInstr NOP = ptext (sLit "\tnop")
1335 pprInstr (CLTD II32) = ptext (sLit "\tcltd")
1336 pprInstr (CLTD II64) = ptext (sLit "\tcqto")
1338 pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op)
1340 pprInstr (JXX cond (BlockId id))
1341 = pprCondInstr (sLit "j") cond (pprCLabel_asm lab)
1342 where lab = mkAsmTempLabel id
1344 pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm)
1346 pprInstr (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm)
1347 pprInstr (JMP op) = (<>) (ptext (sLit "\tjmp *")) (pprOperand wordSize op)
1348 pprInstr (JMP_TBL op ids) = pprInstr (JMP op)
1349 pprInstr (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm)
1350 pprInstr (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg wordSize reg)
1352 pprInstr (IDIV sz op) = pprSizeOp (sLit "idiv") sz op
1353 pprInstr (DIV sz op) = pprSizeOp (sLit "div") sz op
1354 pprInstr (IMUL2 sz op) = pprSizeOp (sLit "imul") sz op
1356 #if x86_64_TARGET_ARCH
1357 pprInstr (MUL size op1 op2) = pprSizeOpOp (sLit "mul") size op1 op2
1359 pprInstr (FDIV size op1 op2) = pprSizeOpOp (sLit "div") size op1 op2
1361 pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to
1362 pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to
1363 pprInstr (CVTTSS2SIQ from to) = pprOpReg (sLit "cvttss2siq") from to
1364 pprInstr (CVTTSD2SIQ from to) = pprOpReg (sLit "cvttsd2siq") from to
1365 pprInstr (CVTSI2SS from to) = pprOpReg (sLit "cvtsi2ssq") from to
1366 pprInstr (CVTSI2SD from to) = pprOpReg (sLit "cvtsi2sdq") from to
1369 -- FETCHGOT for PIC on ELF platforms
1370 pprInstr (FETCHGOT reg)
1371 = vcat [ ptext (sLit "\tcall 1f"),
1372 hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ],
1373 hcat [ ptext (sLit "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "),
1377 -- FETCHPC for PIC on Darwin/x86
1378 -- get the instruction pointer into a register
1379 -- (Terminology note: the IP is called Program Counter on PPC,
1380 -- and it's a good thing to use the same name on both platforms)
1381 pprInstr (FETCHPC reg)
1382 = vcat [ ptext (sLit "\tcall 1f"),
1383 hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ]
1390 -- -----------------------------------------------------------------------------
1391 -- i386 floating-point
1393 #if i386_TARGET_ARCH
1394 -- Simulating a flat register set on the x86 FP stack is tricky.
1395 -- you have to free %st(7) before pushing anything on the FP reg stack
1396 -- so as to preclude the possibility of a FP stack overflow exception.
1397 pprInstr g@(GMOV src dst)
1401 = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
1403 -- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FSTP (dst+1)
1404 pprInstr g@(GLD sz addr dst)
1405 = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp,
1406 pprAddr addr, gsemi, gpop dst 1])
1408 -- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
1409 pprInstr g@(GST sz src addr)
1410 = pprG g (hcat [gtab, gpush src 0, gsemi,
1411 text "fstp", pprSize sz, gsp, pprAddr addr])
1413 pprInstr g@(GLDZ dst)
1414 = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1])
1415 pprInstr g@(GLD1 dst)
1416 = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1])
1418 pprInstr g@(GFTOI src dst)
1419 = pprInstr (GDTOI src dst)
1420 pprInstr g@(GDTOI src dst)
1422 hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"],
1423 hcat [gtab, gpush src 0],
1424 hcat [gtab, text "movzwl 4(%esp), ", reg,
1425 text " ; orl $0xC00, ", reg],
1426 hcat [gtab, text "movl ", reg, text ", 0(%esp) ; fldcw 0(%esp)"],
1427 hcat [gtab, text "fistpl 0(%esp)"],
1428 hcat [gtab, text "fldcw 4(%esp) ; movl 0(%esp), ", reg],
1429 hcat [gtab, text "addl $8, %esp"]
1432 reg = pprReg II32 dst
1434 pprInstr g@(GITOF src dst)
1435 = pprInstr (GITOD src dst)
1436 pprInstr g@(GITOD src dst)
1437 = pprG g (hcat [gtab, text "pushl ", pprReg II32 src,
1438 text " ; ffree %st(7); fildl (%esp) ; ",
1439 gpop dst 1, text " ; addl $4,%esp"])
1441 {- Gruesome swamp follows. If you're unfortunate enough to have ventured
1442 this far into the jungle AND you give a Rat's Ass (tm) what's going
1443 on, here's the deal. Generate code to do a floating point comparison
1444 of src1 and src2, of kind cond, and set the Zero flag if true.
1446 The complications are to do with handling NaNs correctly. We want the
1447 property that if either argument is NaN, then the result of the
1448 comparison is False ... except if we're comparing for inequality,
1449 in which case the answer is True.
1451 Here's how the general (non-inequality) case works. As an
1452 example, consider generating the an equality test:
1454 pushl %eax -- we need to mess with this
1455 <get src1 to top of FPU stack>
1456 fcomp <src2 location in FPU stack> and pop pushed src1
1457 -- Result of comparison is in FPU Status Register bits
1459 fstsw %ax -- Move FPU Status Reg to %ax
1460 sahf -- move C3 C2 C0 from %ax to integer flag reg
1461 -- now the serious magic begins
1462 setpo %ah -- %ah = if comparable(neither arg was NaN) then 1 else 0
1463 sete %al -- %al = if arg1 == arg2 then 1 else 0
1464 andb %ah,%al -- %al &= %ah
1465 -- so %al == 1 iff (comparable && same); else it holds 0
1466 decb %al -- %al == 0, ZeroFlag=1 iff (comparable && same);
1467 else %al == 0xFF, ZeroFlag=0
1468 -- the zero flag is now set as we desire.
1471 The special case of inequality differs thusly:
1473 setpe %ah -- %ah = if incomparable(either arg was NaN) then 1 else 0
1474 setne %al -- %al = if arg1 /= arg2 then 1 else 0
1475 orb %ah,%al -- %al = if (incomparable || different) then 1 else 0
1476 decb %al -- if (incomparable || different) then (%al == 0, ZF=1)
1477 else (%al == 0xFF, ZF=0)
1479 pprInstr g@(GCMP cond src1 src2)
1480 | case cond of { NE -> True; other -> False }
1482 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1483 hcat [gtab, text "fcomp ", greg src2 1,
1484 text "; fstsw %ax ; sahf ; setpe %ah"],
1485 hcat [gtab, text "setne %al ; ",
1486 text "orb %ah,%al ; decb %al ; popl %eax"]
1490 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1491 hcat [gtab, text "fcomp ", greg src2 1,
1492 text "; fstsw %ax ; sahf ; setpo %ah"],
1493 hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ; ",
1494 text "andb %ah,%al ; decb %al ; popl %eax"]
1497 {- On the 486, the flags set by FP compare are the unsigned ones!
1498 (This looks like a HACK to me. WDP 96/03)
1500 fix_FP_cond :: Cond -> Cond
1501 fix_FP_cond GE = GEU
1502 fix_FP_cond GTT = GU
1503 fix_FP_cond LTT = LU
1504 fix_FP_cond LE = LEU
1505 fix_FP_cond EQQ = EQQ
1507 -- there should be no others
1510 pprInstr g@(GABS sz src dst)
1511 = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
1512 pprInstr g@(GNEG sz src dst)
1513 = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
1515 pprInstr g@(GSQRT sz src dst)
1516 = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
1517 hcat [gtab, gcoerceto sz, gpop dst 1])
1518 pprInstr g@(GSIN sz l1 l2 src dst)
1519 = pprG g (pprTrigOp "fsin" False l1 l2 src dst sz)
1520 pprInstr g@(GCOS sz l1 l2 src dst)
1521 = pprG g (pprTrigOp "fcos" False l1 l2 src dst sz)
1522 pprInstr g@(GTAN sz l1 l2 src dst)
1523 = pprG g (pprTrigOp "fptan" True l1 l2 src dst sz)
1525 -- In the translations for GADD, GMUL, GSUB and GDIV,
1526 -- the first two cases are mere optimisations. The otherwise clause
1527 -- generates correct code under all circumstances.
1529 pprInstr g@(GADD sz src1 src2 dst)
1531 = pprG g (text "\t#GADD-xxxcase1" $$
1532 hcat [gtab, gpush src2 0,
1533 text " ; faddp %st(0),", greg src1 1])
1535 = pprG g (text "\t#GADD-xxxcase2" $$
1536 hcat [gtab, gpush src1 0,
1537 text " ; faddp %st(0),", greg src2 1])
1539 = pprG g (hcat [gtab, gpush src1 0,
1540 text " ; fadd ", greg src2 1, text ",%st(0)",
1544 pprInstr g@(GMUL sz src1 src2 dst)
1546 = pprG g (text "\t#GMUL-xxxcase1" $$
1547 hcat [gtab, gpush src2 0,
1548 text " ; fmulp %st(0),", greg src1 1])
1550 = pprG g (text "\t#GMUL-xxxcase2" $$
1551 hcat [gtab, gpush src1 0,
1552 text " ; fmulp %st(0),", greg src2 1])
1554 = pprG g (hcat [gtab, gpush src1 0,
1555 text " ; fmul ", greg src2 1, text ",%st(0)",
1559 pprInstr g@(GSUB sz src1 src2 dst)
1561 = pprG g (text "\t#GSUB-xxxcase1" $$
1562 hcat [gtab, gpush src2 0,
1563 text " ; fsubrp %st(0),", greg src1 1])
1565 = pprG g (text "\t#GSUB-xxxcase2" $$
1566 hcat [gtab, gpush src1 0,
1567 text " ; fsubp %st(0),", greg src2 1])
1569 = pprG g (hcat [gtab, gpush src1 0,
1570 text " ; fsub ", greg src2 1, text ",%st(0)",
1574 pprInstr g@(GDIV sz src1 src2 dst)
1576 = pprG g (text "\t#GDIV-xxxcase1" $$
1577 hcat [gtab, gpush src2 0,
1578 text " ; fdivrp %st(0),", greg src1 1])
1580 = pprG g (text "\t#GDIV-xxxcase2" $$
1581 hcat [gtab, gpush src1 0,
1582 text " ; fdivp %st(0),", greg src2 1])
1584 = pprG g (hcat [gtab, gpush src1 0,
1585 text " ; fdiv ", greg src2 1, text ",%st(0)",
1590 = vcat [ ptext (sLit "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
1591 ptext (sLit "\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)")
1594 pprTrigOp :: String -> Bool -> CLabel -> CLabel -> Reg -> Reg -> Size -> Doc
1595 pprTrigOp op -- fsin, fcos or fptan
1596 isTan -- we need a couple of extra steps if we're doing tan
1597 l1 l2 -- internal labels for us to use
1599 = -- We'll be needing %eax later on
1600 hcat [gtab, text "pushl %eax;"] $$
1601 -- tan is going to use an extra space on the FP stack
1602 (if isTan then hcat [gtab, text "ffree %st(6)"] else empty) $$
1603 -- First put the value in %st(0) and try to apply the op to it
1604 hcat [gpush src 0, text ("; " ++ op)] $$
1605 -- Now look to see if C2 was set (overflow, |value| >= 2^63)
1606 hcat [gtab, text "fnstsw %ax"] $$
1607 hcat [gtab, text "test $0x400,%eax"] $$
1608 -- If we were in bounds then jump to the end
1609 hcat [gtab, text "je " <> pprCLabel_asm l1] $$
1610 -- Otherwise we need to shrink the value. Start by
1611 -- loading pi, doubleing it (by adding it to itself),
1612 -- and then swapping pi with the value, so the value we
1613 -- want to apply op to is in %st(0) again
1614 hcat [gtab, text "ffree %st(7); fldpi"] $$
1615 hcat [gtab, text "fadd %st(0),%st"] $$
1616 hcat [gtab, text "fxch %st(1)"] $$
1617 -- Now we have a loop in which we make the value smaller,
1618 -- see if it's small enough, and loop if not
1619 (pprCLabel_asm l2 <> char ':') $$
1620 hcat [gtab, text "fprem1"] $$
1621 -- My Debian libc uses fstsw here for the tan code, but I can't
1622 -- see any reason why it should need to be different for tan.
1623 hcat [gtab, text "fnstsw %ax"] $$
1624 hcat [gtab, text "test $0x400,%eax"] $$
1625 hcat [gtab, text "jne " <> pprCLabel_asm l2] $$
1626 hcat [gtab, text "fstp %st(1)"] $$
1627 hcat [gtab, text op] $$
1628 (pprCLabel_asm l1 <> char ':') $$
1629 -- Pop the 1.0 tan gave us
1630 (if isTan then hcat [gtab, text "fstp %st(0)"] else empty) $$
1632 hcat [gtab, text "popl %eax;"] $$
1633 -- And finally make the result the right size
1634 hcat [gtab, gcoerceto sz, gpop dst 1]
1636 --------------------------
1638 -- coerce %st(0) to the specified size
1639 gcoerceto FF64 = empty
1640 gcoerceto FF32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
1643 = hcat [text "ffree %st(7) ; fld ", greg reg offset]
1645 = hcat [text "fstp ", greg reg offset]
1647 greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
1652 gregno (RealReg i) = i
1653 gregno other = --pprPanic "gregno" (ppr other)
1654 999 -- bogus; only needed for debug printing
1656 pprG :: Instr -> Doc -> Doc
1658 = (char '#' <> pprGInstr fake) $$ actual
1660 pprGInstr (GMOV src dst) = pprSizeRegReg (sLit "gmov") FF64 src dst
1661 pprGInstr (GLD sz src dst) = pprSizeAddrReg (sLit "gld") sz src dst
1662 pprGInstr (GST sz src dst) = pprSizeRegAddr (sLit "gst") sz src dst
1664 pprGInstr (GLDZ dst) = pprSizeReg (sLit "gldz") FF64 dst
1665 pprGInstr (GLD1 dst) = pprSizeReg (sLit "gld1") FF64 dst
1667 pprGInstr (GFTOI src dst) = pprSizeSizeRegReg (sLit "gftoi") FF32 II32 src dst
1668 pprGInstr (GDTOI src dst) = pprSizeSizeRegReg (sLit "gdtoi") FF64 II32 src dst
1670 pprGInstr (GITOF src dst) = pprSizeSizeRegReg (sLit "gitof") II32 FF32 src dst
1671 pprGInstr (GITOD src dst) = pprSizeSizeRegReg (sLit "gitod") II32 FF64 src dst
1673 pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 co src dst
1674 pprGInstr (GABS sz src dst) = pprSizeRegReg (sLit "gabs") sz src dst
1675 pprGInstr (GNEG sz src dst) = pprSizeRegReg (sLit "gneg") sz src dst
1676 pprGInstr (GSQRT sz src dst) = pprSizeRegReg (sLit "gsqrt") sz src dst
1677 pprGInstr (GSIN sz _ _ src dst) = pprSizeRegReg (sLit "gsin") sz src dst
1678 pprGInstr (GCOS sz _ _ src dst) = pprSizeRegReg (sLit "gcos") sz src dst
1679 pprGInstr (GTAN sz _ _ src dst) = pprSizeRegReg (sLit "gtan") sz src dst
1681 pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg (sLit "gadd") sz src1 src2 dst
1682 pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg (sLit "gsub") sz src1 src2 dst
1683 pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg (sLit "gmul") sz src1 src2 dst
1684 pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg (sLit "gdiv") sz src1 src2 dst
1687 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1689 -- Continue with I386-only printing bits and bobs:
1691 pprDollImm :: Imm -> Doc
1693 pprDollImm i = ptext (sLit "$") <> pprImm i
1695 pprOperand :: Size -> Operand -> Doc
1696 pprOperand s (OpReg r) = pprReg s r
1697 pprOperand s (OpImm i) = pprDollImm i
1698 pprOperand s (OpAddr ea) = pprAddr ea
1700 pprMnemonic_ :: LitString -> Doc
1702 char '\t' <> ptext name <> space
1704 pprMnemonic :: LitString -> Size -> Doc
1705 pprMnemonic name size =
1706 char '\t' <> ptext name <> pprSize size <> space
1708 pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc
1709 pprSizeImmOp name size imm op1
1711 pprMnemonic name size,
1718 pprSizeOp :: LitString -> Size -> Operand -> Doc
1719 pprSizeOp name size op1
1721 pprMnemonic name size,
1725 pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1726 pprSizeOpOp name size op1 op2
1728 pprMnemonic name size,
1729 pprOperand size op1,
1734 pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1735 pprOpOp name size op1 op2
1738 pprOperand size op1,
1743 pprSizeReg :: LitString -> Size -> Reg -> Doc
1744 pprSizeReg name size reg1
1746 pprMnemonic name size,
1750 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
1751 pprSizeRegReg name size reg1 reg2
1753 pprMnemonic name size,
1759 pprRegReg :: LitString -> Reg -> Reg -> Doc
1760 pprRegReg name reg1 reg2
1763 pprReg wordSize reg1,
1765 pprReg wordSize reg2
1768 pprOpReg :: LitString -> Operand -> Reg -> Doc
1769 pprOpReg name op1 reg2
1772 pprOperand wordSize op1,
1774 pprReg wordSize reg2
1777 pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc
1778 pprCondRegReg name size cond reg1 reg2
1789 pprSizeSizeRegReg :: LitString -> Size -> Size -> Reg -> Reg -> Doc
1790 pprSizeSizeRegReg name size1 size2 reg1 reg2
1803 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1804 pprSizeRegRegReg name size reg1 reg2 reg3
1806 pprMnemonic name size,
1814 pprSizeAddrReg :: LitString -> Size -> AddrMode -> Reg -> Doc
1815 pprSizeAddrReg name size op dst
1817 pprMnemonic name size,
1823 pprSizeRegAddr :: LitString -> Size -> Reg -> AddrMode -> Doc
1824 pprSizeRegAddr name size src op
1826 pprMnemonic name size,
1832 pprShift :: LitString -> Size -> Operand -> Operand -> Doc
1833 pprShift name size src dest
1835 pprMnemonic name size,
1836 pprOperand II8 src, -- src is 8-bit sized
1838 pprOperand size dest
1841 pprSizeOpOpCoerce :: LitString -> Size -> Size -> Operand -> Operand -> Doc
1842 pprSizeOpOpCoerce name size1 size2 op1 op2
1843 = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
1844 pprOperand size1 op1,
1846 pprOperand size2 op2
1849 pprCondInstr :: LitString -> Cond -> Doc -> Doc
1850 pprCondInstr name cond arg
1851 = hcat [ char '\t', ptext name, pprCond cond, space, arg]
1853 #endif /* i386_TARGET_ARCH */
1856 -- ------------------------------------------------------------------------------- pprInstr for a SPARC
1858 #if sparc_TARGET_ARCH
1860 -- a clumsy hack for now, to handle possible double alignment problems
1862 -- even clumsier, to allow for RegReg regs that show when doing indexed
1863 -- reads (bytearrays).
1866 pprInstr (SPILL reg slot)
1868 ptext (sLit "\tSPILL"),
1872 ptext (sLit "SLOT") <> parens (int slot)]
1874 pprInstr (RELOAD slot reg)
1876 ptext (sLit "\tRELOAD"),
1878 ptext (sLit "SLOT") <> parens (int slot),
1882 -- Translate to the following:
1885 -- ld [g1+4],%f(n+1)
1886 -- sub g1,g2,g1 -- to restore g1
1888 pprInstr (LD FF64 (AddrRegReg g1 g2) reg)
1889 = let Just regH = fPair reg
1891 hcat [ptext (sLit "\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1892 hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg],
1893 hcat [pp_ld_lbracket, pprReg g1, ptext (sLit "+4]"), comma, pprReg regH],
1894 hcat [ptext (sLit "\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1899 -- ld [addr+4],%f(n+1)
1900 pprInstr (LD FF64 addr reg)
1901 = let Just addr2 = addrOffset addr 4
1902 Just regH = fPair reg
1904 hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
1905 hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg regH]
1909 pprInstr (LD size addr reg)
1911 ptext (sLit "\tld"),
1920 -- The same clumsy hack as above
1922 -- Translate to the following:
1925 -- st %f(n+1),[g1+4]
1926 -- sub g1,g2,g1 -- to restore g1
1927 pprInstr (ST FF64 reg (AddrRegReg g1 g2))
1928 = let Just regH = fPair reg
1930 hcat [ptext (sLit "\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1931 hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket,
1933 hcat [ptext (sLit "\tst\t"), pprReg regH, pp_comma_lbracket,
1934 pprReg g1, ptext (sLit "+4]")],
1935 hcat [ptext (sLit "\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1940 -- st %f(n+1),[addr+4]
1941 pprInstr instr@(ST FF64 reg addr)
1942 = let Just addr2 = addrOffset addr 4
1943 Just regH = fPair reg
1945 hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket,
1946 pprAddr addr, rbrack],
1947 hcat [ptext (sLit "\tst\t"), pprReg regH, pp_comma_lbracket,
1948 pprAddr addr2, rbrack]
1953 -- no distinction is made between signed and unsigned bytes on stores for the
1954 -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
1955 -- so we call a special-purpose pprSize for ST..
1957 pprInstr (ST size reg addr)
1959 ptext (sLit "\tst"),
1968 pprInstr (ADD x cc reg1 ri reg2)
1969 | not x && not cc && riZero ri
1970 = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1973 = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2
1975 pprInstr (SUB x cc reg1 ri reg2)
1976 | not x && cc && reg2 == g0
1977 = hcat [ ptext (sLit "\tcmp\t"), pprReg reg1, comma, pprRI ri ]
1978 | not x && not cc && riZero ri
1979 = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1981 = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2
1983 pprInstr (AND b reg1 ri reg2) = pprRegRIReg (sLit "and") b reg1 ri reg2
1984 pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2
1986 pprInstr (OR b reg1 ri reg2)
1987 | not b && reg1 == g0
1988 = let doit = hcat [ ptext (sLit "\tmov\t"), pprRI ri, comma, pprReg reg2 ]
1990 RIReg rrr | rrr == reg2 -> empty
1994 = pprRegRIReg (sLit "or") b reg1 ri reg2
1996 pprInstr (ORN b reg1 ri reg2) = pprRegRIReg (sLit "orn") b reg1 ri reg2
1998 pprInstr (XOR b reg1 ri reg2) = pprRegRIReg (sLit "xor") b reg1 ri reg2
1999 pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg (sLit "xnor") b reg1 ri reg2
2001 pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") False reg1 ri reg2
2002 pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") False reg1 ri reg2
2003 pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") False reg1 ri reg2
2005 pprInstr (RDY rd) = ptext (sLit "\trd\t%y,") <> pprReg rd
2006 pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul") b reg1 ri reg2
2007 pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul") b reg1 ri reg2
2009 pprInstr (SETHI imm reg)
2011 ptext (sLit "\tsethi\t"),
2017 pprInstr NOP = ptext (sLit "\tnop")
2019 pprInstr (FABS FF32 reg1 reg2) = pprSizeRegReg (sLit "fabs") FF32 reg1 reg2
2020 pprInstr (FABS FF64 reg1 reg2)
2021 = let Just reg1H = fPair reg1
2022 Just reg2H = fPair reg2
2024 (<>) (pprSizeRegReg (sLit "fabs") FF32 reg1 reg2)
2025 (if (reg1 == reg2) then empty
2026 else (<>) (char '\n')
2027 (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
2029 pprInstr (FADD size reg1 reg2 reg3)
2030 = pprSizeRegRegReg (sLit "fadd") size reg1 reg2 reg3
2031 pprInstr (FCMP e size reg1 reg2)
2032 = pprSizeRegReg (if e then sLit "fcmpe" else sLit "fcmp") size reg1 reg2
2033 pprInstr (FDIV size reg1 reg2 reg3)
2034 = pprSizeRegRegReg (sLit "fdiv") size reg1 reg2 reg3
2036 pprInstr (FMOV FF32 reg1 reg2) = pprSizeRegReg (sLit "fmov") FF32 reg1 reg2
2037 pprInstr (FMOV FF64 reg1 reg2) = pprSizeRegReg (sLit "fmov") FF64 reg1 reg2
2040 pprInstr (FMOV FF64 reg1 reg2)
2041 = let Just reg1H = fPair reg1
2042 Just reg2H = fPair reg2
2044 (<>) (pprSizeRegReg (sLit "fmov") FF32 reg1 reg2)
2045 (if (reg1 == reg2) then empty
2046 else (<>) (char '\n')
2047 (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
2050 pprInstr (FMUL size reg1 reg2 reg3)
2051 = pprSizeRegRegReg (sLit "fmul") size reg1 reg2 reg3
2053 pprInstr (FNEG FF32 reg1 reg2) = pprSizeRegReg (sLit "fneg") FF32 reg1 reg2
2054 pprInstr (FNEG FF64 reg1 reg2)
2055 = let Just reg1H = fPair reg1
2056 Just reg2H = fPair reg2
2058 (<>) (pprSizeRegReg (sLit "fneg") FF32 reg1 reg2)
2059 (if (reg1 == reg2) then empty
2060 else (<>) (char '\n')
2061 (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
2063 pprInstr (FSQRT size reg1 reg2) = pprSizeRegReg (sLit "fsqrt") size reg1 reg2
2064 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fsub") size reg1 reg2 reg3
2065 pprInstr (FxTOy size1 size2 reg1 reg2)
2072 FF64 -> sLit "dto"),
2077 FF64 -> sLit "d\t"),
2078 pprReg reg1, comma, pprReg reg2
2082 pprInstr (BI cond b (BlockId id))
2084 ptext (sLit "\tb"), pprCond cond,
2085 if b then pp_comma_a else empty,
2087 pprCLabel_asm (mkAsmTempLabel id)
2090 pprInstr (BF cond b (BlockId id))
2092 ptext (sLit "\tfb"), pprCond cond,
2093 if b then pp_comma_a else empty,
2095 pprCLabel_asm (mkAsmTempLabel id)
2098 pprInstr (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr addr)
2100 pprInstr (CALL (Left imm) n _)
2101 = hcat [ ptext (sLit "\tcall\t"), pprImm imm, comma, int n ]
2102 pprInstr (CALL (Right reg) n _)
2103 = hcat [ ptext (sLit "\tcall\t"), pprReg reg, comma, int n ]
2106 pprRI (RIReg r) = pprReg r
2107 pprRI (RIImm r) = pprImm r
2109 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
2110 pprSizeRegReg name size reg1 reg2
2115 FF32 -> ptext (sLit "s\t")
2116 FF64 -> ptext (sLit "d\t")),
2122 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
2123 pprSizeRegRegReg name size reg1 reg2 reg3
2128 FF32 -> ptext (sLit "s\t")
2129 FF64 -> ptext (sLit "d\t")),
2137 pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
2138 pprRegRIReg name b reg1 ri reg2
2142 if b then ptext (sLit "cc\t") else char '\t',
2150 pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
2151 pprRIReg name b ri reg1
2155 if b then ptext (sLit "cc\t") else char '\t',
2161 pp_ld_lbracket = ptext (sLit "\tld\t[")
2162 pp_rbracket_comma = text "],"
2163 pp_comma_lbracket = text ",["
2164 pp_comma_a = text ",a"
2166 #endif /* sparc_TARGET_ARCH */
2169 -- -----------------------------------------------------------------------------
2170 -- pprInstr for PowerPC
2172 #if powerpc_TARGET_ARCH
2174 pprInstr (SPILL reg slot)
2176 ptext (sLit "\tSPILL"),
2180 ptext (sLit "SLOT") <> parens (int slot)]
2182 pprInstr (RELOAD slot reg)
2184 ptext (sLit "\tRELOAD"),
2186 ptext (sLit "SLOT") <> parens (int slot),
2190 pprInstr (LD sz reg addr) = hcat [
2199 case addr of AddrRegImm _ _ -> empty
2200 AddrRegReg _ _ -> char 'x',
2206 pprInstr (LA sz reg addr) = hcat [
2215 case addr of AddrRegImm _ _ -> empty
2216 AddrRegReg _ _ -> char 'x',
2222 pprInstr (ST sz reg addr) = hcat [
2226 case addr of AddrRegImm _ _ -> empty
2227 AddrRegReg _ _ -> char 'x',
2233 pprInstr (STU sz reg addr) = hcat [
2238 case addr of AddrRegImm _ _ -> empty
2239 AddrRegReg _ _ -> char 'x',
2244 pprInstr (LIS reg imm) = hcat [
2252 pprInstr (LI reg imm) = hcat [
2260 pprInstr (MR reg1 reg2)
2261 | reg1 == reg2 = empty
2262 | otherwise = hcat [
2264 case regClass reg1 of
2265 RcInteger -> ptext (sLit "mr")
2266 _ -> ptext (sLit "fmr"),
2272 pprInstr (CMP sz reg ri) = hcat [
2288 pprInstr (CMPL sz reg ri) = hcat [
2298 ptext (sLit "cmpl"),
2304 pprInstr (BCC cond (BlockId id)) = hcat [
2311 where lbl = mkAsmTempLabel id
2313 pprInstr (BCCFAR cond (BlockId id)) = vcat [
2316 pprCond (condNegate cond),
2317 ptext (sLit "\t$+8")
2320 ptext (sLit "\tb\t"),
2324 where lbl = mkAsmTempLabel id
2326 pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
2333 pprInstr (MTCTR reg) = hcat [
2335 ptext (sLit "mtctr"),
2339 pprInstr (BCTR _) = hcat [
2343 pprInstr (BL lbl _) = hcat [
2344 ptext (sLit "\tbl\t"),
2347 pprInstr (BCTRL _) = hcat [
2349 ptext (sLit "bctrl")
2351 pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri
2352 pprInstr (ADDIS reg1 reg2 imm) = hcat [
2354 ptext (sLit "addis"),
2363 pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3)
2364 pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3)
2365 pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3)
2366 pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri
2367 pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri
2368 pprInstr (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3)
2369 pprInstr (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3)
2371 pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
2372 hcat [ ptext (sLit "\tmullwo\t"), pprReg reg1, ptext (sLit ", "),
2373 pprReg reg2, ptext (sLit ", "),
2375 hcat [ ptext (sLit "\tmfxer\t"), pprReg reg1 ],
2376 hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "),
2377 pprReg reg1, ptext (sLit ", "),
2378 ptext (sLit "2, 31, 31") ]
2381 -- for some reason, "andi" doesn't exist.
2382 -- we'll use "andi." instead.
2383 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
2385 ptext (sLit "andi."),
2393 pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri
2395 pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri
2396 pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri
2398 pprInstr (XORIS reg1 reg2 imm) = hcat [
2400 ptext (sLit "xoris"),
2409 pprInstr (EXTS sz reg1 reg2) = hcat [
2411 ptext (sLit "exts"),
2419 pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2
2420 pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2
2422 pprInstr (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri)
2423 pprInstr (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri)
2424 pprInstr (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri)
2425 pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
2426 ptext (sLit "\trlwinm\t"),
2438 pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF (sLit "fadd") sz reg1 reg2 reg3
2439 pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF (sLit "fsub") sz reg1 reg2 reg3
2440 pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF (sLit "fmul") sz reg1 reg2 reg3
2441 pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") sz reg1 reg2 reg3
2442 pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2
2444 pprInstr (FCMP reg1 reg2) = hcat [
2446 ptext (sLit "fcmpu\tcr0, "),
2447 -- Note: we're using fcmpu, not fcmpo
2448 -- The difference is with fcmpo, compare with NaN is an invalid operation.
2449 -- We don't handle invalid fp ops, so we don't care
2455 pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2
2456 pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2
2458 pprInstr (CRNOR dst src1 src2) = hcat [
2459 ptext (sLit "\tcrnor\t"),
2467 pprInstr (MFCR reg) = hcat [
2469 ptext (sLit "mfcr"),
2474 pprInstr (MFLR reg) = hcat [
2476 ptext (sLit "mflr"),
2481 pprInstr (FETCHPC reg) = vcat [
2482 ptext (sLit "\tbcl\t20,31,1f"),
2483 hcat [ ptext (sLit "1:\tmflr\t"), pprReg reg ]
2486 pprInstr LWSYNC = ptext (sLit "\tlwsync")
2488 pprInstr _ = panic "pprInstr (ppc)"
2490 pprLogic op reg1 reg2 ri = hcat [
2495 RIImm _ -> char 'i',
2504 pprUnary op reg1 reg2 = hcat [
2513 pprBinaryF op sz reg1 reg2 reg3 = hcat [
2526 pprRI (RIReg r) = pprReg r
2527 pprRI (RIImm r) = pprImm r
2529 pprFSize FF64 = empty
2530 pprFSize FF32 = char 's'
2532 -- limit immediate argument for shift instruction to range 0..32
2533 -- (yes, the maximum is really 32, not 31)
2534 limitShiftRI :: RI -> RI
2535 limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32)
2538 #endif /* powerpc_TARGET_ARCH */
2541 -- -----------------------------------------------------------------------------
2542 -- Converting floating-point literals to integrals for printing
2544 castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)
2545 castFloatToWord8Array = castSTUArray
2547 castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8)
2548 castDoubleToWord8Array = castSTUArray
2550 -- floatToBytes and doubleToBytes convert to the host's byte
2551 -- order. Providing that we're not cross-compiling for a
2552 -- target with the opposite endianness, this should work ok
2555 -- ToDo: this stuff is very similar to the shenanigans in PprAbs,
2556 -- could they be merged?
2558 floatToBytes :: Float -> [Int]
2561 arr <- newArray_ ((0::Int),3)
2563 arr <- castFloatToWord8Array arr
2564 i0 <- readArray arr 0
2565 i1 <- readArray arr 1
2566 i2 <- readArray arr 2
2567 i3 <- readArray arr 3
2568 return (map fromIntegral [i0,i1,i2,i3])
2571 doubleToBytes :: Double -> [Int]
2574 arr <- newArray_ ((0::Int),7)
2576 arr <- castDoubleToWord8Array arr
2577 i0 <- readArray arr 0
2578 i1 <- readArray arr 1
2579 i2 <- readArray arr 2
2580 i3 <- readArray arr 3
2581 i4 <- readArray arr 4
2582 i5 <- readArray arr 5
2583 i6 <- readArray arr 6
2584 i7 <- readArray arr 7
2585 return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7])