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, pprImm
27 #include "HsVersions.h"
31 import Regs -- may differ per-platform
35 import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel,
36 labelDynamic, mkAsmTempLabel, entryLblToInfoLbl )
37 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
38 import CLabel ( mkDeadStripPreventer )
41 import Panic ( panic )
42 import Unique ( pprUnique )
45 import qualified Outputable
46 import Outputable ( Outputable, pprPanic, ppr, docToSDoc)
49 import Data.Word ( Word8 )
50 import Control.Monad.ST
51 import Data.Char ( chr, ord )
52 import Data.Maybe ( isJust )
54 #if powerpc_TARGET_ARCH || darwin_TARGET_OS
55 import Data.Word(Word32)
59 -- -----------------------------------------------------------------------------
60 -- Printing this stuff out
62 asmSDoc d = Outputable.withPprStyleDoc (
63 Outputable.mkCodeStyle Outputable.AsmStyle) d
64 pprCLabel_asm l = asmSDoc (pprCLabel l)
66 pprNatCmmTop :: NatCmmTop -> Doc
67 pprNatCmmTop (CmmData section dats) =
68 pprSectionHeader section $$ vcat (map pprData dats)
70 -- special case for split markers:
71 pprNatCmmTop (CmmProc [] lbl _ (ListGraph [])) = pprLabel lbl
73 pprNatCmmTop (CmmProc info lbl params (ListGraph blocks)) =
74 pprSectionHeader Text $$
75 (if null info then -- blocks guaranteed not null, so label needed
78 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
79 pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
82 vcat (map pprData info) $$
83 pprLabel (entryLblToInfoLbl lbl)
85 vcat (map pprBasicBlock blocks)
86 -- above: Even the first block gets a label, because with branch-chain
87 -- elimination, it might be the target of a goto.
88 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
89 -- If we are using the .subsections_via_symbols directive
90 -- (available on recent versions of Darwin),
91 -- we have to make sure that there is some kind of reference
92 -- from the entry code to a label on the _top_ of of the info table,
93 -- so that the linker will not think it is unreferenced and dead-strip
94 -- it. That's why the label is called a DeadStripPreventer (_dsp).
97 <+> pprCLabel_asm (entryLblToInfoLbl lbl)
99 <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
104 pprBasicBlock :: NatBasicBlock -> Doc
105 pprBasicBlock (BasicBlock (BlockId id) instrs) =
106 pprLabel (mkAsmTempLabel id) $$
107 vcat (map pprInstr instrs)
109 -- -----------------------------------------------------------------------------
110 -- pprReg: print a 'Reg'
112 -- For x86, the way we print a register name depends
113 -- on which bit of it we care about. Yurgh.
115 pprUserReg :: Reg -> Doc
116 pprUserReg = pprReg IF_ARCH_i386(II32,) IF_ARCH_x86_64(II64,)
118 pprReg :: IF_ARCH_i386(Size ->,) IF_ARCH_x86_64(Size ->,) Reg -> Doc
120 pprReg IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) r
122 RealReg i -> ppr_reg_no IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) i
123 VirtualRegI u -> text "%vI_" <> asmSDoc (pprUnique u)
124 VirtualRegHi u -> text "%vHi_" <> asmSDoc (pprUnique u)
125 VirtualRegF u -> text "%vF_" <> asmSDoc (pprUnique u)
126 VirtualRegD u -> text "%vD_" <> asmSDoc (pprUnique u)
128 #if alpha_TARGET_ARCH
129 ppr_reg_no :: Int -> Doc
132 0 -> sLit "$0"; 1 -> sLit "$1";
133 2 -> sLit "$2"; 3 -> sLit "$3";
134 4 -> sLit "$4"; 5 -> sLit "$5";
135 6 -> sLit "$6"; 7 -> sLit "$7";
136 8 -> sLit "$8"; 9 -> sLit "$9";
137 10 -> sLit "$10"; 11 -> sLit "$11";
138 12 -> sLit "$12"; 13 -> sLit "$13";
139 14 -> sLit "$14"; 15 -> sLit "$15";
140 16 -> sLit "$16"; 17 -> sLit "$17";
141 18 -> sLit "$18"; 19 -> sLit "$19";
142 20 -> sLit "$20"; 21 -> sLit "$21";
143 22 -> sLit "$22"; 23 -> sLit "$23";
144 24 -> sLit "$24"; 25 -> sLit "$25";
145 26 -> sLit "$26"; 27 -> sLit "$27";
146 28 -> sLit "$28"; 29 -> sLit "$29";
147 30 -> sLit "$30"; 31 -> sLit "$31";
148 32 -> sLit "$f0"; 33 -> sLit "$f1";
149 34 -> sLit "$f2"; 35 -> sLit "$f3";
150 36 -> sLit "$f4"; 37 -> sLit "$f5";
151 38 -> sLit "$f6"; 39 -> sLit "$f7";
152 40 -> sLit "$f8"; 41 -> sLit "$f9";
153 42 -> sLit "$f10"; 43 -> sLit "$f11";
154 44 -> sLit "$f12"; 45 -> sLit "$f13";
155 46 -> sLit "$f14"; 47 -> sLit "$f15";
156 48 -> sLit "$f16"; 49 -> sLit "$f17";
157 50 -> sLit "$f18"; 51 -> sLit "$f19";
158 52 -> sLit "$f20"; 53 -> sLit "$f21";
159 54 -> sLit "$f22"; 55 -> sLit "$f23";
160 56 -> sLit "$f24"; 57 -> sLit "$f25";
161 58 -> sLit "$f26"; 59 -> sLit "$f27";
162 60 -> sLit "$f28"; 61 -> sLit "$f29";
163 62 -> sLit "$f30"; 63 -> sLit "$f31";
164 _ -> sLit "very naughty alpha register"
168 ppr_reg_no :: Size -> Int -> Doc
169 ppr_reg_no II8 = ppr_reg_byte
170 ppr_reg_no II16 = ppr_reg_word
171 ppr_reg_no _ = ppr_reg_long
173 ppr_reg_byte i = ptext
175 0 -> sLit "%al"; 1 -> sLit "%bl";
176 2 -> sLit "%cl"; 3 -> sLit "%dl";
177 _ -> sLit "very naughty I386 byte register"
180 ppr_reg_word i = ptext
182 0 -> sLit "%ax"; 1 -> sLit "%bx";
183 2 -> sLit "%cx"; 3 -> sLit "%dx";
184 4 -> sLit "%si"; 5 -> sLit "%di";
185 6 -> sLit "%bp"; 7 -> sLit "%sp";
186 _ -> sLit "very naughty I386 word register"
189 ppr_reg_long i = ptext
191 0 -> sLit "%eax"; 1 -> sLit "%ebx";
192 2 -> sLit "%ecx"; 3 -> sLit "%edx";
193 4 -> sLit "%esi"; 5 -> sLit "%edi";
194 6 -> sLit "%ebp"; 7 -> sLit "%esp";
195 8 -> sLit "%fake0"; 9 -> sLit "%fake1";
196 10 -> sLit "%fake2"; 11 -> sLit "%fake3";
197 12 -> sLit "%fake4"; 13 -> sLit "%fake5";
198 _ -> sLit "very naughty I386 register"
202 #if x86_64_TARGET_ARCH
203 ppr_reg_no :: Size -> Int -> Doc
204 ppr_reg_no II8 = ppr_reg_byte
205 ppr_reg_no II16 = ppr_reg_word
206 ppr_reg_no II32 = ppr_reg_long
207 ppr_reg_no _ = ppr_reg_quad
209 ppr_reg_byte i = ptext
211 0 -> sLit "%al"; 1 -> sLit "%bl";
212 2 -> sLit "%cl"; 3 -> sLit "%dl";
213 4 -> sLit "%sil"; 5 -> sLit "%dil"; -- new 8-bit regs!
214 6 -> sLit "%bpl"; 7 -> sLit "%spl";
215 8 -> sLit "%r8b"; 9 -> sLit "%r9b";
216 10 -> sLit "%r10b"; 11 -> sLit "%r11b";
217 12 -> sLit "%r12b"; 13 -> sLit "%r13b";
218 14 -> sLit "%r14b"; 15 -> sLit "%r15b";
219 _ -> sLit "very naughty x86_64 byte register"
222 ppr_reg_word i = ptext
224 0 -> sLit "%ax"; 1 -> sLit "%bx";
225 2 -> sLit "%cx"; 3 -> sLit "%dx";
226 4 -> sLit "%si"; 5 -> sLit "%di";
227 6 -> sLit "%bp"; 7 -> sLit "%sp";
228 8 -> sLit "%r8w"; 9 -> sLit "%r9w";
229 10 -> sLit "%r10w"; 11 -> sLit "%r11w";
230 12 -> sLit "%r12w"; 13 -> sLit "%r13w";
231 14 -> sLit "%r14w"; 15 -> sLit "%r15w";
232 _ -> sLit "very naughty x86_64 word register"
235 ppr_reg_long i = ptext
237 0 -> sLit "%eax"; 1 -> sLit "%ebx";
238 2 -> sLit "%ecx"; 3 -> sLit "%edx";
239 4 -> sLit "%esi"; 5 -> sLit "%edi";
240 6 -> sLit "%ebp"; 7 -> sLit "%esp";
241 8 -> sLit "%r8d"; 9 -> sLit "%r9d";
242 10 -> sLit "%r10d"; 11 -> sLit "%r11d";
243 12 -> sLit "%r12d"; 13 -> sLit "%r13d";
244 14 -> sLit "%r14d"; 15 -> sLit "%r15d";
245 _ -> sLit "very naughty x86_64 register"
248 ppr_reg_quad i = ptext
250 0 -> sLit "%rax"; 1 -> sLit "%rbx";
251 2 -> sLit "%rcx"; 3 -> sLit "%rdx";
252 4 -> sLit "%rsi"; 5 -> sLit "%rdi";
253 6 -> sLit "%rbp"; 7 -> sLit "%rsp";
254 8 -> sLit "%r8"; 9 -> sLit "%r9";
255 10 -> sLit "%r10"; 11 -> sLit "%r11";
256 12 -> sLit "%r12"; 13 -> sLit "%r13";
257 14 -> sLit "%r14"; 15 -> sLit "%r15";
258 16 -> sLit "%xmm0"; 17 -> sLit "%xmm1";
259 18 -> sLit "%xmm2"; 19 -> sLit "%xmm3";
260 20 -> sLit "%xmm4"; 21 -> sLit "%xmm5";
261 22 -> sLit "%xmm6"; 23 -> sLit "%xmm7";
262 24 -> sLit "%xmm8"; 25 -> sLit "%xmm9";
263 26 -> sLit "%xmm10"; 27 -> sLit "%xmm11";
264 28 -> sLit "%xmm12"; 29 -> sLit "%xmm13";
265 30 -> sLit "%xmm14"; 31 -> sLit "%xmm15";
266 _ -> sLit "very naughty x86_64 register"
270 #if sparc_TARGET_ARCH
271 ppr_reg_no :: Int -> Doc
274 0 -> sLit "%g0"; 1 -> sLit "%g1";
275 2 -> sLit "%g2"; 3 -> sLit "%g3";
276 4 -> sLit "%g4"; 5 -> sLit "%g5";
277 6 -> sLit "%g6"; 7 -> sLit "%g7";
278 8 -> sLit "%o0"; 9 -> sLit "%o1";
279 10 -> sLit "%o2"; 11 -> sLit "%o3";
280 12 -> sLit "%o4"; 13 -> sLit "%o5";
281 14 -> sLit "%o6"; 15 -> sLit "%o7";
282 16 -> sLit "%l0"; 17 -> sLit "%l1";
283 18 -> sLit "%l2"; 19 -> sLit "%l3";
284 20 -> sLit "%l4"; 21 -> sLit "%l5";
285 22 -> sLit "%l6"; 23 -> sLit "%l7";
286 24 -> sLit "%i0"; 25 -> sLit "%i1";
287 26 -> sLit "%i2"; 27 -> sLit "%i3";
288 28 -> sLit "%i4"; 29 -> sLit "%i5";
289 30 -> sLit "%i6"; 31 -> sLit "%i7";
290 32 -> sLit "%f0"; 33 -> sLit "%f1";
291 34 -> sLit "%f2"; 35 -> sLit "%f3";
292 36 -> sLit "%f4"; 37 -> sLit "%f5";
293 38 -> sLit "%f6"; 39 -> sLit "%f7";
294 40 -> sLit "%f8"; 41 -> sLit "%f9";
295 42 -> sLit "%f10"; 43 -> sLit "%f11";
296 44 -> sLit "%f12"; 45 -> sLit "%f13";
297 46 -> sLit "%f14"; 47 -> sLit "%f15";
298 48 -> sLit "%f16"; 49 -> sLit "%f17";
299 50 -> sLit "%f18"; 51 -> sLit "%f19";
300 52 -> sLit "%f20"; 53 -> sLit "%f21";
301 54 -> sLit "%f22"; 55 -> sLit "%f23";
302 56 -> sLit "%f24"; 57 -> sLit "%f25";
303 58 -> sLit "%f26"; 59 -> sLit "%f27";
304 60 -> sLit "%f28"; 61 -> sLit "%f29";
305 62 -> sLit "%f30"; 63 -> sLit "%f31";
306 _ -> sLit "very naughty sparc register"
309 #if powerpc_TARGET_ARCH
311 ppr_reg_no :: Int -> Doc
314 0 -> sLit "r0"; 1 -> sLit "r1";
315 2 -> sLit "r2"; 3 -> sLit "r3";
316 4 -> sLit "r4"; 5 -> sLit "r5";
317 6 -> sLit "r6"; 7 -> sLit "r7";
318 8 -> sLit "r8"; 9 -> sLit "r9";
319 10 -> sLit "r10"; 11 -> sLit "r11";
320 12 -> sLit "r12"; 13 -> sLit "r13";
321 14 -> sLit "r14"; 15 -> sLit "r15";
322 16 -> sLit "r16"; 17 -> sLit "r17";
323 18 -> sLit "r18"; 19 -> sLit "r19";
324 20 -> sLit "r20"; 21 -> sLit "r21";
325 22 -> sLit "r22"; 23 -> sLit "r23";
326 24 -> sLit "r24"; 25 -> sLit "r25";
327 26 -> sLit "r26"; 27 -> sLit "r27";
328 28 -> sLit "r28"; 29 -> sLit "r29";
329 30 -> sLit "r30"; 31 -> sLit "r31";
330 32 -> sLit "f0"; 33 -> sLit "f1";
331 34 -> sLit "f2"; 35 -> sLit "f3";
332 36 -> sLit "f4"; 37 -> sLit "f5";
333 38 -> sLit "f6"; 39 -> sLit "f7";
334 40 -> sLit "f8"; 41 -> sLit "f9";
335 42 -> sLit "f10"; 43 -> sLit "f11";
336 44 -> sLit "f12"; 45 -> sLit "f13";
337 46 -> sLit "f14"; 47 -> sLit "f15";
338 48 -> sLit "f16"; 49 -> sLit "f17";
339 50 -> sLit "f18"; 51 -> sLit "f19";
340 52 -> sLit "f20"; 53 -> sLit "f21";
341 54 -> sLit "f22"; 55 -> sLit "f23";
342 56 -> sLit "f24"; 57 -> sLit "f25";
343 58 -> sLit "f26"; 59 -> sLit "f27";
344 60 -> sLit "f28"; 61 -> sLit "f29";
345 62 -> sLit "f30"; 63 -> sLit "f31";
346 _ -> sLit "very naughty powerpc register"
349 ppr_reg_no :: Int -> Doc
350 ppr_reg_no i | i <= 31 = int i -- GPRs
351 | i <= 63 = int (i-32) -- FPRs
352 | otherwise = ptext (sLit "very naughty powerpc register")
357 -- -----------------------------------------------------------------------------
359 -- Used for instruction suffixes.
360 -- eg LD is 32bit on sparc, but LDD is 64 bit.
363 #if powerpc_TARGET_ARCH || i386_TARGET_ARCH || x86_64_TARGET_ARCH || sparc_TARGET_ARCH
364 pprSize :: Size -> 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 FF32 -> sLit "ss" -- "scalar single-precision float" (SSE2)
396 FF64 -> sLit "sd" -- "scalar double-precision float" (SSE2)
398 #if sparc_TARGET_ARCH
407 -- suffix to store/ ST instruction
408 pprStSize :: Size -> Doc
409 pprStSize x = ptext (case x of
417 #if powerpc_TARGET_ARCH
426 -- -----------------------------------------------------------------------------
427 -- pprCond: print a 'Cond'
429 pprCond :: Cond -> Doc
431 pprCond c = ptext (case c of {
432 #if alpha_TARGET_ARCH
442 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
443 GEU -> sLit "ae"; LU -> sLit "b";
444 EQQ -> sLit "e"; GTT -> sLit "g";
445 GE -> sLit "ge"; GU -> sLit "a";
446 LTT -> sLit "l"; LE -> sLit "le";
447 LEU -> sLit "be"; NE -> sLit "ne";
448 NEG -> sLit "s"; POS -> sLit "ns";
449 CARRY -> sLit "c"; OFLO -> sLit "o";
450 PARITY -> sLit "p"; NOTPARITY -> sLit "np";
451 ALWAYS -> sLit "mp" -- hack
453 #if sparc_TARGET_ARCH
454 ALWAYS -> sLit ""; NEVER -> sLit "n";
455 GEU -> sLit "geu"; LU -> sLit "lu";
456 EQQ -> sLit "e"; GTT -> sLit "g";
457 GE -> sLit "ge"; GU -> sLit "gu";
458 LTT -> sLit "l"; LE -> sLit "le";
459 LEU -> sLit "leu"; NE -> sLit "ne";
460 NEG -> sLit "neg"; POS -> sLit "pos";
461 VC -> sLit "vc"; VS -> sLit "vs"
463 #if powerpc_TARGET_ARCH
465 EQQ -> sLit "eq"; NE -> sLit "ne";
466 LTT -> sLit "lt"; GE -> sLit "ge";
467 GTT -> sLit "gt"; LE -> sLit "le";
468 LU -> sLit "lt"; GEU -> sLit "ge";
469 GU -> sLit "gt"; LEU -> sLit "le";
474 -- -----------------------------------------------------------------------------
475 -- pprImm: print an 'Imm'
479 pprImm (ImmInt i) = int i
480 pprImm (ImmInteger i) = integer i
481 pprImm (ImmCLbl l) = pprCLabel_asm l
482 pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i
483 pprImm (ImmLit s) = s
485 pprImm (ImmFloat _) = ptext (sLit "naughty float immediate")
486 pprImm (ImmDouble _) = ptext (sLit "naughty double immediate")
488 pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
489 -- #if sparc_TARGET_ARCH
490 -- ToDo: This should really be fixed in the PIC support, but only
492 -- pprImm (ImmConstantDiff a b) = pprImm a
494 pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
495 <> lparen <> pprImm b <> rparen
498 #if sparc_TARGET_ARCH
500 = hcat [ pp_lo, pprImm i, rparen ]
505 = hcat [ pp_hi, pprImm i, rparen ]
509 #if powerpc_TARGET_ARCH
512 = hcat [ pp_lo, pprImm i, rparen ]
517 = hcat [ pp_hi, pprImm i, rparen ]
522 = hcat [ pp_ha, pprImm i, rparen ]
528 = pprImm i <> text "@l"
531 = pprImm i <> text "@h"
534 = pprImm i <> text "@ha"
539 -- -----------------------------------------------------------------------------
540 -- @pprAddr: print an 'AddrMode'
542 pprAddr :: AddrMode -> Doc
544 #if alpha_TARGET_ARCH
545 pprAddr (AddrReg r) = parens (pprReg r)
546 pprAddr (AddrImm i) = pprImm i
547 pprAddr (AddrRegImm r1 i)
548 = (<>) (pprImm i) (parens (pprReg r1))
553 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
554 pprAddr (ImmAddr imm off)
555 = let pp_imm = pprImm imm
559 else if (off < 0) then
562 pp_imm <> char '+' <> int off
564 pprAddr (AddrBaseIndex base index displacement)
566 pp_disp = ppr_disp displacement
567 pp_off p = pp_disp <> char '(' <> p <> char ')'
568 pp_reg r = pprReg wordSize r
571 (EABaseNone, EAIndexNone) -> pp_disp
572 (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b)
573 (EABaseRip, EAIndexNone) -> pp_off (ptext (sLit "%rip"))
574 (EABaseNone, EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i)
575 (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r
578 ppr_disp (ImmInt 0) = empty
579 ppr_disp imm = pprImm imm
584 #if sparc_TARGET_ARCH
585 pprAddr (AddrRegReg r1 (RealReg 0)) = pprReg r1
587 pprAddr (AddrRegReg r1 r2)
588 = hcat [ pprReg r1, char '+', pprReg r2 ]
590 pprAddr (AddrRegImm r1 (ImmInt i))
592 | not (fits13Bits i) = largeOffsetError i
593 | otherwise = hcat [ pprReg r1, pp_sign, int i ]
595 pp_sign = if i > 0 then char '+' else empty
597 pprAddr (AddrRegImm r1 (ImmInteger i))
599 | not (fits13Bits i) = largeOffsetError i
600 | otherwise = hcat [ pprReg r1, pp_sign, integer i ]
602 pp_sign = if i > 0 then char '+' else empty
604 pprAddr (AddrRegImm r1 imm)
605 = hcat [ pprReg r1, char '+', pprImm imm ]
610 #if powerpc_TARGET_ARCH
611 pprAddr (AddrRegReg r1 r2)
612 = pprReg r1 <+> ptext (sLit ", ") <+> pprReg r2
614 pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ]
615 pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ]
616 pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]
620 -- -----------------------------------------------------------------------------
621 -- pprData: print a 'CmmStatic'
623 pprSectionHeader Text
625 (IF_ARCH_alpha(sLit "\t.text\n\t.align 3" {-word boundary-}
626 ,IF_ARCH_sparc(sLit ".text\n\t.align 4" {-word boundary-}
627 ,IF_ARCH_i386(IF_OS_darwin(sLit ".text\n\t.align 2",
628 sLit ".text\n\t.align 4,0x90")
629 {-needs per-OS variation!-}
630 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".text\n.align 3",
631 sLit ".text\n\t.align 8")
632 ,IF_ARCH_powerpc(sLit ".text\n.align 2"
634 pprSectionHeader Data
636 (IF_ARCH_alpha(sLit "\t.data\n\t.align 3"
637 ,IF_ARCH_sparc(sLit ".data\n\t.align 8" {-<8 will break double constants -}
638 ,IF_ARCH_i386(IF_OS_darwin(sLit ".data\n\t.align 2",
639 sLit ".data\n\t.align 4")
640 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".data\n.align 3",
641 sLit ".data\n\t.align 8")
642 ,IF_ARCH_powerpc(sLit ".data\n.align 2"
644 pprSectionHeader ReadOnlyData
646 (IF_ARCH_alpha(sLit "\t.data\n\t.align 3"
647 ,IF_ARCH_sparc(sLit ".text\n\t.align 8" {-<8 will break double constants -}
648 ,IF_ARCH_i386(IF_OS_darwin(sLit ".const\n.align 2",
649 sLit ".section .rodata\n\t.align 4")
650 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".const\n.align 3",
651 sLit ".section .rodata\n\t.align 8")
652 ,IF_ARCH_powerpc(IF_OS_darwin(sLit ".const\n.align 2",
653 sLit ".section .rodata\n\t.align 2")
655 pprSectionHeader RelocatableReadOnlyData
657 (IF_ARCH_alpha(sLit "\t.data\n\t.align 3"
658 ,IF_ARCH_sparc(sLit ".text\n\t.align 8" {-<8 will break double constants -}
659 ,IF_ARCH_i386(IF_OS_darwin(sLit ".const_data\n.align 2",
660 sLit ".section .data\n\t.align 4")
661 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".const_data\n.align 3",
662 sLit ".section .data\n\t.align 8")
663 ,IF_ARCH_powerpc(IF_OS_darwin(sLit ".const_data\n.align 2",
664 sLit ".data\n\t.align 2")
666 pprSectionHeader UninitialisedData
668 (IF_ARCH_alpha(sLit "\t.bss\n\t.align 3"
669 ,IF_ARCH_sparc(sLit ".bss\n\t.align 8" {-<8 will break double constants -}
670 ,IF_ARCH_i386(IF_OS_darwin(sLit ".data\n\t.align 2",
671 sLit ".section .bss\n\t.align 4")
672 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".data\n\t.align 3",
673 sLit ".section .bss\n\t.align 8")
674 ,IF_ARCH_powerpc(IF_OS_darwin(sLit ".const_data\n.align 2",
675 sLit ".section .bss\n\t.align 2")
677 pprSectionHeader ReadOnlyData16
679 (IF_ARCH_alpha(sLit "\t.data\n\t.align 4"
680 ,IF_ARCH_sparc(sLit ".data\n\t.align 16"
681 ,IF_ARCH_i386(IF_OS_darwin(sLit ".const\n.align 4",
682 sLit ".section .rodata\n\t.align 16")
683 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".const\n.align 4",
684 sLit ".section .rodata.cst16\n\t.align 16")
685 ,IF_ARCH_powerpc(IF_OS_darwin(sLit ".const\n.align 4",
686 sLit ".section .rodata\n\t.align 4")
689 pprSectionHeader (OtherSection sec)
690 = panic "PprMach.pprSectionHeader: unknown section"
692 pprData :: CmmStatic -> Doc
693 pprData (CmmAlign bytes) = pprAlign bytes
694 pprData (CmmDataLabel lbl) = pprLabel lbl
695 pprData (CmmString str) = pprASCII str
696 pprData (CmmUninitialised bytes) = ptext (sLit s) <> int bytes
698 #if defined(solaris2_TARGET_OS)
703 pprData (CmmStaticLit lit) = pprDataItem lit
705 pprGloblDecl :: CLabel -> Doc
707 | not (externallyVisibleCLabel lbl) = empty
708 | otherwise = ptext IF_ARCH_sparc((sLit ".global "),
712 pprTypeAndSizeDecl :: CLabel -> Doc
713 pprTypeAndSizeDecl lbl
715 | not (externallyVisibleCLabel lbl) = empty
716 | otherwise = ptext (sLit ".type ") <>
717 pprCLabel_asm lbl <> ptext (sLit ", @object")
722 pprLabel :: CLabel -> Doc
723 pprLabel lbl = pprGloblDecl lbl $$ pprTypeAndSizeDecl lbl $$ (pprCLabel_asm lbl <> char ':')
727 = vcat (map do1 str) $$ do1 0
730 do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w)
733 IF_ARCH_alpha(ptext (sLit ".align ") <> int pow2,
734 IF_ARCH_i386(ptext (sLit ".align ") <> int IF_OS_darwin(pow2,bytes),
735 IF_ARCH_x86_64(ptext (sLit ".align ") <> int IF_OS_darwin(pow2,bytes),
736 IF_ARCH_sparc(ptext (sLit ".align ") <> int bytes,
737 IF_ARCH_powerpc(ptext (sLit ".align ") <> int pow2,)))))
741 log2 :: Int -> Int -- cache the common ones
746 log2 n = 1 + log2 (n `quot` 2)
749 pprDataItem :: CmmLit -> Doc
751 = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit)
755 -- These seem to be common:
756 ppr_item II8 x = [ptext (sLit "\t.byte\t") <> pprImm imm]
757 ppr_item II32 x = [ptext (sLit "\t.long\t") <> pprImm imm]
758 ppr_item FF32 (CmmFloat r _)
759 = let bs = floatToBytes (fromRational r)
760 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
761 ppr_item FF64 (CmmFloat r _)
762 = let bs = doubleToBytes (fromRational r)
763 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
765 #if sparc_TARGET_ARCH
766 -- copy n paste of x86 version
767 ppr_item II16 x = [ptext (sLit "\t.short\t") <> pprImm imm]
768 ppr_item II64 x = [ptext (sLit "\t.quad\t") <> pprImm imm]
770 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
771 ppr_item II16 x = [ptext (sLit "\t.word\t") <> pprImm imm]
773 #if i386_TARGET_ARCH && darwin_TARGET_OS
774 ppr_item II64 (CmmInt x _) =
775 [ptext (sLit "\t.long\t")
776 <> int (fromIntegral (fromIntegral x :: Word32)),
777 ptext (sLit "\t.long\t")
779 (fromIntegral (x `shiftR` 32) :: Word32))]
781 #if i386_TARGET_ARCH || (darwin_TARGET_OS && x86_64_TARGET_ARCH)
782 ppr_item II64 x = [ptext (sLit "\t.quad\t") <> pprImm imm]
784 #if x86_64_TARGET_ARCH && !darwin_TARGET_OS
785 -- x86_64: binutils can't handle the R_X86_64_PC64 relocation
786 -- type, which means we can't do pc-relative 64-bit addresses.
787 -- Fortunately we're assuming the small memory model, in which
788 -- all such offsets will fit into 32 bits, so we have to stick
789 -- to 32-bit offset fields and modify the RTS appropriately
791 -- See Note [x86-64-relative] in includes/InfoTables.h
794 | isRelativeReloc x =
795 [ptext (sLit "\t.long\t") <> pprImm imm,
796 ptext (sLit "\t.long\t0")]
798 [ptext (sLit "\t.quad\t") <> pprImm imm]
800 isRelativeReloc (CmmLabelDiffOff _ _ _) = True
801 isRelativeReloc _ = False
803 #if powerpc_TARGET_ARCH
804 ppr_item II16 x = [ptext (sLit "\t.short\t") <> pprImm imm]
805 ppr_item II64 (CmmInt x _) =
806 [ptext (sLit "\t.long\t")
808 (fromIntegral (x `shiftR` 32) :: Word32)),
809 ptext (sLit "\t.long\t")
810 <> int (fromIntegral (fromIntegral x :: Word32))]
813 -- fall through to rest of (machine-specific) pprInstr...
815 -- -----------------------------------------------------------------------------
816 -- pprInstr: print an 'Instr'
818 instance Outputable Instr where
819 ppr instr = Outputable.docToSDoc $ pprInstr instr
821 pprInstr :: Instr -> Doc
823 pprInstr (COMMENT s) = empty -- nuke 'em
826 = IF_ARCH_alpha( ((<>) (ptext (sLit "\t# ")) (ftext s))
827 ,IF_ARCH_sparc( ((<>) (ptext (sLit "# ")) (ftext s))
828 ,IF_ARCH_i386( ((<>) (ptext (sLit "# ")) (ftext s))
829 ,IF_ARCH_x86_64( ((<>) (ptext (sLit "# ")) (ftext s))
830 ,IF_ARCH_powerpc( IF_OS_linux(
831 ((<>) (ptext (sLit "# ")) (ftext s)),
832 ((<>) (ptext (sLit "; ")) (ftext s)))
836 = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
838 pprInstr (NEWBLOCK _)
839 = panic "PprMach.pprInstr: NEWBLOCK"
842 = panic "PprMach.pprInstr: LDATA"
844 -- -----------------------------------------------------------------------------
845 -- pprInstr for an Alpha
847 #if alpha_TARGET_ARCH
849 pprInstr (SPILL reg slot)
851 ptext (sLit "\tSPILL"),
855 ptext (sLit "SLOT") <> parens (int slot)]
857 pprInstr (RELOAD slot reg)
859 ptext (sLit "\tRELOAD"),
861 ptext (sLit "SLOT") <> parens (int slot),
865 pprInstr (LD size reg addr)
875 pprInstr (LDA reg addr)
877 ptext (sLit "\tlda\t"),
883 pprInstr (LDAH reg addr)
885 ptext (sLit "\tldah\t"),
891 pprInstr (LDGP reg addr)
893 ptext (sLit "\tldgp\t"),
899 pprInstr (LDI size reg imm)
901 ptext (sLit "\tldi"),
909 pprInstr (ST size reg addr)
921 ptext (sLit "\tclr\t"),
925 pprInstr (ABS size ri reg)
927 ptext (sLit "\tabs"),
935 pprInstr (NEG size ov ri reg)
937 ptext (sLit "\tneg"),
939 if ov then ptext (sLit "v\t") else char '\t',
945 pprInstr (ADD size ov reg1 ri reg2)
947 ptext (sLit "\tadd"),
949 if ov then ptext (sLit "v\t") else char '\t',
957 pprInstr (SADD size scale reg1 ri reg2)
959 ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
970 pprInstr (SUB size ov reg1 ri reg2)
972 ptext (sLit "\tsub"),
974 if ov then ptext (sLit "v\t") else char '\t',
982 pprInstr (SSUB size scale reg1 ri reg2)
984 ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
995 pprInstr (MUL size ov reg1 ri reg2)
997 ptext (sLit "\tmul"),
999 if ov then ptext (sLit "v\t") else char '\t',
1007 pprInstr (DIV size uns reg1 ri reg2)
1009 ptext (sLit "\tdiv"),
1011 if uns then ptext (sLit "u\t") else char '\t',
1019 pprInstr (REM size uns reg1 ri reg2)
1021 ptext (sLit "\trem"),
1023 if uns then ptext (sLit "u\t") else char '\t',
1031 pprInstr (NOT ri reg)
1033 ptext (sLit "\tnot"),
1040 pprInstr (AND reg1 ri reg2) = pprRegRIReg (sLit "and") reg1 ri reg2
1041 pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg (sLit "andnot") reg1 ri reg2
1042 pprInstr (OR reg1 ri reg2) = pprRegRIReg (sLit "or") reg1 ri reg2
1043 pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg (sLit "ornot") reg1 ri reg2
1044 pprInstr (XOR reg1 ri reg2) = pprRegRIReg (sLit "xor") reg1 ri reg2
1045 pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg (sLit "xornot") reg1 ri reg2
1047 pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") reg1 ri reg2
1048 pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") reg1 ri reg2
1049 pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") reg1 ri reg2
1051 pprInstr (ZAP reg1 ri reg2) = pprRegRIReg (sLit "zap") reg1 ri reg2
1052 pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg (sLit "zapnot") reg1 ri reg2
1054 pprInstr (NOP) = ptext (sLit "\tnop")
1056 pprInstr (CMP cond reg1 ri reg2)
1058 ptext (sLit "\tcmp"),
1070 ptext (sLit "\tfclr\t"),
1074 pprInstr (FABS reg1 reg2)
1076 ptext (sLit "\tfabs\t"),
1082 pprInstr (FNEG size reg1 reg2)
1084 ptext (sLit "\tneg"),
1092 pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "add") size reg1 reg2 reg3
1093 pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "div") size reg1 reg2 reg3
1094 pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "mul") size reg1 reg2 reg3
1095 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "sub") size reg1 reg2 reg3
1097 pprInstr (CVTxy size1 size2 reg1 reg2)
1099 ptext (sLit "\tcvt"),
1101 case size2 of {Q -> ptext (sLit "qc"); _ -> pprSize size2},
1108 pprInstr (FCMP size cond reg1 reg2 reg3)
1110 ptext (sLit "\tcmp"),
1121 pprInstr (FMOV reg1 reg2)
1123 ptext (sLit "\tfmov\t"),
1129 pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
1131 pprInstr (BI NEVER reg lab) = empty
1133 pprInstr (BI cond reg lab)
1143 pprInstr (BF cond reg lab)
1145 ptext (sLit "\tfb"),
1154 = (<>) (ptext (sLit "\tbr\t")) (pprImm lab)
1156 pprInstr (JMP reg addr hint)
1158 ptext (sLit "\tjmp\t"),
1166 pprInstr (BSR imm n)
1167 = (<>) (ptext (sLit "\tbsr\t")) (pprImm imm)
1169 pprInstr (JSR reg addr n)
1171 ptext (sLit "\tjsr\t"),
1177 pprInstr (FUNBEGIN clab)
1179 if (externallyVisibleCLabel clab) then
1180 hcat [ptext (sLit "\t.globl\t"), pp_lab, char '\n']
1183 ptext (sLit "\t.ent "),
1192 pp_lab = pprCLabel_asm clab
1194 -- NEVER use commas within those string literals, cpp will ruin your day
1195 pp_ldgp = hcat [ ptext (sLit ":\n\tldgp $29"), char ',', ptext (sLit "0($27)\n") ]
1196 pp_frame = hcat [ ptext (sLit "..ng:\n\t.frame $30"), char ',',
1197 ptext (sLit "4240"), char ',',
1198 ptext (sLit "$26"), char ',',
1199 ptext (sLit "0\n\t.prologue 1") ]
1201 pprInstr (FUNEND clab)
1202 = (<>) (ptext (sLit "\t.align 4\n\t.end ")) (pprCLabel_asm clab)
1205 Continue with Alpha-only printing bits and bobs:
1209 pprRI (RIReg r) = pprReg r
1210 pprRI (RIImm r) = pprImm r
1212 pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
1213 pprRegRIReg name reg1 ri reg2
1225 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1226 pprSizeRegRegReg name size reg1 reg2 reg3
1239 #endif /* alpha_TARGET_ARCH */
1242 -- -----------------------------------------------------------------------------
1243 -- pprInstr for an x86
1245 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1247 pprInstr (SPILL reg slot)
1249 ptext (sLit "\tSPILL"),
1253 ptext (sLit "SLOT") <> parens (int slot)]
1255 pprInstr (RELOAD slot reg)
1257 ptext (sLit "\tRELOAD"),
1259 ptext (sLit "SLOT") <> parens (int slot),
1263 pprInstr (MOV size src dst)
1264 = pprSizeOpOp (sLit "mov") size src dst
1266 pprInstr (MOVZxL II32 src dst) = pprSizeOpOp (sLit "mov") II32 src dst
1267 -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple
1268 -- movl. But we represent it as a MOVZxL instruction, because
1269 -- the reg alloc would tend to throw away a plain reg-to-reg
1270 -- move, and we still want it to do that.
1272 pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce (sLit "movz") sizes II32 src dst
1273 -- zero-extension only needs to extend to 32 bits: on x86_64,
1274 -- the remaining zero-extension to 64 bits is automatic, and the 32-bit
1275 -- instruction is shorter.
1277 pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce (sLit "movs") sizes wordSize src dst
1279 -- here we do some patching, since the physical registers are only set late
1280 -- in the code generation.
1281 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1283 = pprSizeOpOp (sLit "add") size (OpReg reg2) dst
1284 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1286 = pprSizeOpOp (sLit "add") size (OpReg reg1) dst
1287 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))
1289 = pprInstr (ADD size (OpImm displ) dst)
1290 pprInstr (LEA size src dst) = pprSizeOpOp (sLit "lea") size src dst
1292 pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
1293 = pprSizeOp (sLit "dec") size dst
1294 pprInstr (ADD size (OpImm (ImmInt 1)) dst)
1295 = pprSizeOp (sLit "inc") size dst
1296 pprInstr (ADD size src dst)
1297 = pprSizeOpOp (sLit "add") size src dst
1298 pprInstr (ADC size src dst)
1299 = pprSizeOpOp (sLit "adc") size src dst
1300 pprInstr (SUB size src dst) = pprSizeOpOp (sLit "sub") size src dst
1301 pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2
1303 {- A hack. The Intel documentation says that "The two and three
1304 operand forms [of IMUL] may also be used with unsigned operands
1305 because the lower half of the product is the same regardless if
1306 (sic) the operands are signed or unsigned. The CF and OF flags,
1307 however, cannot be used to determine if the upper half of the
1308 result is non-zero." So there.
1310 pprInstr (AND size src dst) = pprSizeOpOp (sLit "and") size src dst
1311 pprInstr (OR size src dst) = pprSizeOpOp (sLit "or") size src dst
1313 pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst
1314 pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst
1315 pprInstr (XOR size src dst) = pprSizeOpOp (sLit "xor") size src dst
1317 pprInstr (NOT size op) = pprSizeOp (sLit "not") size op
1318 pprInstr (NEGI size op) = pprSizeOp (sLit "neg") size op
1320 pprInstr (SHL size src dst) = pprShift (sLit "shl") size src dst
1321 pprInstr (SAR size src dst) = pprShift (sLit "sar") size src dst
1322 pprInstr (SHR size src dst) = pprShift (sLit "shr") size src dst
1324 pprInstr (BT size imm src) = pprSizeImmOp (sLit "bt") size imm src
1326 pprInstr (CMP size src dst)
1327 | is_float size = pprSizeOpOp (sLit "ucomi") size src dst -- SSE2
1328 | otherwise = pprSizeOpOp (sLit "cmp") size src dst
1330 -- This predicate is needed here and nowhere else
1331 is_float FF32 = True
1332 is_float FF64 = True
1333 is_float FF80 = True
1334 is_float other = False
1336 pprInstr (TEST size src dst) = pprSizeOpOp (sLit "test") size src dst
1337 pprInstr (PUSH size op) = pprSizeOp (sLit "push") size op
1338 pprInstr (POP size op) = pprSizeOp (sLit "pop") size op
1340 -- both unused (SDM):
1341 -- pprInstr PUSHA = ptext (sLit "\tpushal")
1342 -- pprInstr POPA = ptext (sLit "\tpopal")
1344 pprInstr NOP = ptext (sLit "\tnop")
1345 pprInstr (CLTD II32) = ptext (sLit "\tcltd")
1346 pprInstr (CLTD II64) = ptext (sLit "\tcqto")
1348 pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op)
1350 pprInstr (JXX cond (BlockId id))
1351 = pprCondInstr (sLit "j") cond (pprCLabel_asm lab)
1352 where lab = mkAsmTempLabel id
1354 pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm)
1356 pprInstr (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm)
1357 pprInstr (JMP op) = (<>) (ptext (sLit "\tjmp *")) (pprOperand wordSize op)
1358 pprInstr (JMP_TBL op ids) = pprInstr (JMP op)
1359 pprInstr (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm)
1360 pprInstr (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg wordSize reg)
1362 pprInstr (IDIV sz op) = pprSizeOp (sLit "idiv") sz op
1363 pprInstr (DIV sz op) = pprSizeOp (sLit "div") sz op
1364 pprInstr (IMUL2 sz op) = pprSizeOp (sLit "imul") sz op
1366 #if x86_64_TARGET_ARCH
1367 pprInstr (MUL size op1 op2) = pprSizeOpOp (sLit "mul") size op1 op2
1369 pprInstr (FDIV size op1 op2) = pprSizeOpOp (sLit "div") size op1 op2
1371 pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to
1372 pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to
1373 pprInstr (CVTTSS2SIQ from to) = pprOpReg (sLit "cvttss2siq") from to
1374 pprInstr (CVTTSD2SIQ from to) = pprOpReg (sLit "cvttsd2siq") from to
1375 pprInstr (CVTSI2SS from to) = pprOpReg (sLit "cvtsi2ssq") from to
1376 pprInstr (CVTSI2SD from to) = pprOpReg (sLit "cvtsi2sdq") from to
1379 -- FETCHGOT for PIC on ELF platforms
1380 pprInstr (FETCHGOT reg)
1381 = vcat [ ptext (sLit "\tcall 1f"),
1382 hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ],
1383 hcat [ ptext (sLit "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "),
1387 -- FETCHPC for PIC on Darwin/x86
1388 -- get the instruction pointer into a register
1389 -- (Terminology note: the IP is called Program Counter on PPC,
1390 -- and it's a good thing to use the same name on both platforms)
1391 pprInstr (FETCHPC reg)
1392 = vcat [ ptext (sLit "\tcall 1f"),
1393 hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ]
1400 -- -----------------------------------------------------------------------------
1401 -- i386 floating-point
1403 #if i386_TARGET_ARCH
1404 -- Simulating a flat register set on the x86 FP stack is tricky.
1405 -- you have to free %st(7) before pushing anything on the FP reg stack
1406 -- so as to preclude the possibility of a FP stack overflow exception.
1407 pprInstr g@(GMOV src dst)
1411 = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
1413 -- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FSTP (dst+1)
1414 pprInstr g@(GLD sz addr dst)
1415 = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp,
1416 pprAddr addr, gsemi, gpop dst 1])
1418 -- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
1419 pprInstr g@(GST sz src addr)
1420 = pprG g (hcat [gtab, gpush src 0, gsemi,
1421 text "fstp", pprSize sz, gsp, pprAddr addr])
1423 pprInstr g@(GLDZ dst)
1424 = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1])
1425 pprInstr g@(GLD1 dst)
1426 = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1])
1428 pprInstr g@(GFTOI src dst)
1429 = pprInstr (GDTOI src dst)
1430 pprInstr g@(GDTOI src dst)
1432 hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"],
1433 hcat [gtab, gpush src 0],
1434 hcat [gtab, text "movzwl 4(%esp), ", reg,
1435 text " ; orl $0xC00, ", reg],
1436 hcat [gtab, text "movl ", reg, text ", 0(%esp) ; fldcw 0(%esp)"],
1437 hcat [gtab, text "fistpl 0(%esp)"],
1438 hcat [gtab, text "fldcw 4(%esp) ; movl 0(%esp), ", reg],
1439 hcat [gtab, text "addl $8, %esp"]
1442 reg = pprReg II32 dst
1444 pprInstr g@(GITOF src dst)
1445 = pprInstr (GITOD src dst)
1446 pprInstr g@(GITOD src dst)
1447 = pprG g (hcat [gtab, text "pushl ", pprReg II32 src,
1448 text " ; ffree %st(7); fildl (%esp) ; ",
1449 gpop dst 1, text " ; addl $4,%esp"])
1451 {- Gruesome swamp follows. If you're unfortunate enough to have ventured
1452 this far into the jungle AND you give a Rat's Ass (tm) what's going
1453 on, here's the deal. Generate code to do a floating point comparison
1454 of src1 and src2, of kind cond, and set the Zero flag if true.
1456 The complications are to do with handling NaNs correctly. We want the
1457 property that if either argument is NaN, then the result of the
1458 comparison is False ... except if we're comparing for inequality,
1459 in which case the answer is True.
1461 Here's how the general (non-inequality) case works. As an
1462 example, consider generating the an equality test:
1464 pushl %eax -- we need to mess with this
1465 <get src1 to top of FPU stack>
1466 fcomp <src2 location in FPU stack> and pop pushed src1
1467 -- Result of comparison is in FPU Status Register bits
1469 fstsw %ax -- Move FPU Status Reg to %ax
1470 sahf -- move C3 C2 C0 from %ax to integer flag reg
1471 -- now the serious magic begins
1472 setpo %ah -- %ah = if comparable(neither arg was NaN) then 1 else 0
1473 sete %al -- %al = if arg1 == arg2 then 1 else 0
1474 andb %ah,%al -- %al &= %ah
1475 -- so %al == 1 iff (comparable && same); else it holds 0
1476 decb %al -- %al == 0, ZeroFlag=1 iff (comparable && same);
1477 else %al == 0xFF, ZeroFlag=0
1478 -- the zero flag is now set as we desire.
1481 The special case of inequality differs thusly:
1483 setpe %ah -- %ah = if incomparable(either arg was NaN) then 1 else 0
1484 setne %al -- %al = if arg1 /= arg2 then 1 else 0
1485 orb %ah,%al -- %al = if (incomparable || different) then 1 else 0
1486 decb %al -- if (incomparable || different) then (%al == 0, ZF=1)
1487 else (%al == 0xFF, ZF=0)
1489 pprInstr g@(GCMP cond src1 src2)
1490 | case cond of { NE -> True; other -> False }
1492 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1493 hcat [gtab, text "fcomp ", greg src2 1,
1494 text "; fstsw %ax ; sahf ; setpe %ah"],
1495 hcat [gtab, text "setne %al ; ",
1496 text "orb %ah,%al ; decb %al ; popl %eax"]
1500 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1501 hcat [gtab, text "fcomp ", greg src2 1,
1502 text "; fstsw %ax ; sahf ; setpo %ah"],
1503 hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ; ",
1504 text "andb %ah,%al ; decb %al ; popl %eax"]
1507 {- On the 486, the flags set by FP compare are the unsigned ones!
1508 (This looks like a HACK to me. WDP 96/03)
1510 fix_FP_cond :: Cond -> Cond
1511 fix_FP_cond GE = GEU
1512 fix_FP_cond GTT = GU
1513 fix_FP_cond LTT = LU
1514 fix_FP_cond LE = LEU
1515 fix_FP_cond EQQ = EQQ
1517 -- there should be no others
1520 pprInstr g@(GABS sz src dst)
1521 = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
1522 pprInstr g@(GNEG sz src dst)
1523 = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
1525 pprInstr g@(GSQRT sz src dst)
1526 = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
1527 hcat [gtab, gcoerceto sz, gpop dst 1])
1528 pprInstr g@(GSIN sz l1 l2 src dst)
1529 = pprG g (pprTrigOp "fsin" False l1 l2 src dst sz)
1530 pprInstr g@(GCOS sz l1 l2 src dst)
1531 = pprG g (pprTrigOp "fcos" False l1 l2 src dst sz)
1532 pprInstr g@(GTAN sz l1 l2 src dst)
1533 = pprG g (pprTrigOp "fptan" True l1 l2 src dst sz)
1535 -- In the translations for GADD, GMUL, GSUB and GDIV,
1536 -- the first two cases are mere optimisations. The otherwise clause
1537 -- generates correct code under all circumstances.
1539 pprInstr g@(GADD sz src1 src2 dst)
1541 = pprG g (text "\t#GADD-xxxcase1" $$
1542 hcat [gtab, gpush src2 0,
1543 text " ; faddp %st(0),", greg src1 1])
1545 = pprG g (text "\t#GADD-xxxcase2" $$
1546 hcat [gtab, gpush src1 0,
1547 text " ; faddp %st(0),", greg src2 1])
1549 = pprG g (hcat [gtab, gpush src1 0,
1550 text " ; fadd ", greg src2 1, text ",%st(0)",
1554 pprInstr g@(GMUL sz src1 src2 dst)
1556 = pprG g (text "\t#GMUL-xxxcase1" $$
1557 hcat [gtab, gpush src2 0,
1558 text " ; fmulp %st(0),", greg src1 1])
1560 = pprG g (text "\t#GMUL-xxxcase2" $$
1561 hcat [gtab, gpush src1 0,
1562 text " ; fmulp %st(0),", greg src2 1])
1564 = pprG g (hcat [gtab, gpush src1 0,
1565 text " ; fmul ", greg src2 1, text ",%st(0)",
1569 pprInstr g@(GSUB sz src1 src2 dst)
1571 = pprG g (text "\t#GSUB-xxxcase1" $$
1572 hcat [gtab, gpush src2 0,
1573 text " ; fsubrp %st(0),", greg src1 1])
1575 = pprG g (text "\t#GSUB-xxxcase2" $$
1576 hcat [gtab, gpush src1 0,
1577 text " ; fsubp %st(0),", greg src2 1])
1579 = pprG g (hcat [gtab, gpush src1 0,
1580 text " ; fsub ", greg src2 1, text ",%st(0)",
1584 pprInstr g@(GDIV sz src1 src2 dst)
1586 = pprG g (text "\t#GDIV-xxxcase1" $$
1587 hcat [gtab, gpush src2 0,
1588 text " ; fdivrp %st(0),", greg src1 1])
1590 = pprG g (text "\t#GDIV-xxxcase2" $$
1591 hcat [gtab, gpush src1 0,
1592 text " ; fdivp %st(0),", greg src2 1])
1594 = pprG g (hcat [gtab, gpush src1 0,
1595 text " ; fdiv ", greg src2 1, text ",%st(0)",
1600 = vcat [ ptext (sLit "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
1601 ptext (sLit "\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)")
1604 pprTrigOp :: String -> Bool -> CLabel -> CLabel -> Reg -> Reg -> Size -> Doc
1605 pprTrigOp op -- fsin, fcos or fptan
1606 isTan -- we need a couple of extra steps if we're doing tan
1607 l1 l2 -- internal labels for us to use
1609 = -- We'll be needing %eax later on
1610 hcat [gtab, text "pushl %eax;"] $$
1611 -- tan is going to use an extra space on the FP stack
1612 (if isTan then hcat [gtab, text "ffree %st(6)"] else empty) $$
1613 -- First put the value in %st(0) and try to apply the op to it
1614 hcat [gpush src 0, text ("; " ++ op)] $$
1615 -- Now look to see if C2 was set (overflow, |value| >= 2^63)
1616 hcat [gtab, text "fnstsw %ax"] $$
1617 hcat [gtab, text "test $0x400,%eax"] $$
1618 -- If we were in bounds then jump to the end
1619 hcat [gtab, text "je " <> pprCLabel_asm l1] $$
1620 -- Otherwise we need to shrink the value. Start by
1621 -- loading pi, doubleing it (by adding it to itself),
1622 -- and then swapping pi with the value, so the value we
1623 -- want to apply op to is in %st(0) again
1624 hcat [gtab, text "ffree %st(7); fldpi"] $$
1625 hcat [gtab, text "fadd %st(0),%st"] $$
1626 hcat [gtab, text "fxch %st(1)"] $$
1627 -- Now we have a loop in which we make the value smaller,
1628 -- see if it's small enough, and loop if not
1629 (pprCLabel_asm l2 <> char ':') $$
1630 hcat [gtab, text "fprem1"] $$
1631 -- My Debian libc uses fstsw here for the tan code, but I can't
1632 -- see any reason why it should need to be different for tan.
1633 hcat [gtab, text "fnstsw %ax"] $$
1634 hcat [gtab, text "test $0x400,%eax"] $$
1635 hcat [gtab, text "jne " <> pprCLabel_asm l2] $$
1636 hcat [gtab, text "fstp %st(1)"] $$
1637 hcat [gtab, text op] $$
1638 (pprCLabel_asm l1 <> char ':') $$
1639 -- Pop the 1.0 tan gave us
1640 (if isTan then hcat [gtab, text "fstp %st(0)"] else empty) $$
1642 hcat [gtab, text "popl %eax;"] $$
1643 -- And finally make the result the right size
1644 hcat [gtab, gcoerceto sz, gpop dst 1]
1646 --------------------------
1648 -- coerce %st(0) to the specified size
1649 gcoerceto FF64 = empty
1650 gcoerceto FF32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
1653 = hcat [text "ffree %st(7) ; fld ", greg reg offset]
1655 = hcat [text "fstp ", greg reg offset]
1657 greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
1662 gregno (RealReg i) = i
1663 gregno other = --pprPanic "gregno" (ppr other)
1664 999 -- bogus; only needed for debug printing
1666 pprG :: Instr -> Doc -> Doc
1668 = (char '#' <> pprGInstr fake) $$ actual
1670 pprGInstr (GMOV src dst) = pprSizeRegReg (sLit "gmov") FF64 src dst
1671 pprGInstr (GLD sz src dst) = pprSizeAddrReg (sLit "gld") sz src dst
1672 pprGInstr (GST sz src dst) = pprSizeRegAddr (sLit "gst") sz src dst
1674 pprGInstr (GLDZ dst) = pprSizeReg (sLit "gldz") FF64 dst
1675 pprGInstr (GLD1 dst) = pprSizeReg (sLit "gld1") FF64 dst
1677 pprGInstr (GFTOI src dst) = pprSizeSizeRegReg (sLit "gftoi") FF32 II32 src dst
1678 pprGInstr (GDTOI src dst) = pprSizeSizeRegReg (sLit "gdtoi") FF64 II32 src dst
1680 pprGInstr (GITOF src dst) = pprSizeSizeRegReg (sLit "gitof") II32 FF32 src dst
1681 pprGInstr (GITOD src dst) = pprSizeSizeRegReg (sLit "gitod") II32 FF64 src dst
1683 pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 co src dst
1684 pprGInstr (GABS sz src dst) = pprSizeRegReg (sLit "gabs") sz src dst
1685 pprGInstr (GNEG sz src dst) = pprSizeRegReg (sLit "gneg") sz src dst
1686 pprGInstr (GSQRT sz src dst) = pprSizeRegReg (sLit "gsqrt") sz src dst
1687 pprGInstr (GSIN sz _ _ src dst) = pprSizeRegReg (sLit "gsin") sz src dst
1688 pprGInstr (GCOS sz _ _ src dst) = pprSizeRegReg (sLit "gcos") sz src dst
1689 pprGInstr (GTAN sz _ _ src dst) = pprSizeRegReg (sLit "gtan") sz src dst
1691 pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg (sLit "gadd") sz src1 src2 dst
1692 pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg (sLit "gsub") sz src1 src2 dst
1693 pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg (sLit "gmul") sz src1 src2 dst
1694 pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg (sLit "gdiv") sz src1 src2 dst
1697 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1699 -- Continue with I386-only printing bits and bobs:
1701 pprDollImm :: Imm -> Doc
1703 pprDollImm i = ptext (sLit "$") <> pprImm i
1705 pprOperand :: Size -> Operand -> Doc
1706 pprOperand s (OpReg r) = pprReg s r
1707 pprOperand s (OpImm i) = pprDollImm i
1708 pprOperand s (OpAddr ea) = pprAddr ea
1710 pprMnemonic_ :: LitString -> Doc
1712 char '\t' <> ptext name <> space
1714 pprMnemonic :: LitString -> Size -> Doc
1715 pprMnemonic name size =
1716 char '\t' <> ptext name <> pprSize size <> space
1718 pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc
1719 pprSizeImmOp name size imm op1
1721 pprMnemonic name size,
1728 pprSizeOp :: LitString -> Size -> Operand -> Doc
1729 pprSizeOp name size op1
1731 pprMnemonic name size,
1735 pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1736 pprSizeOpOp name size op1 op2
1738 pprMnemonic name size,
1739 pprOperand size op1,
1744 pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1745 pprOpOp name size op1 op2
1748 pprOperand size op1,
1753 pprSizeReg :: LitString -> Size -> Reg -> Doc
1754 pprSizeReg name size reg1
1756 pprMnemonic name size,
1760 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
1761 pprSizeRegReg name size reg1 reg2
1763 pprMnemonic name size,
1769 pprRegReg :: LitString -> Reg -> Reg -> Doc
1770 pprRegReg name reg1 reg2
1773 pprReg wordSize reg1,
1775 pprReg wordSize reg2
1778 pprOpReg :: LitString -> Operand -> Reg -> Doc
1779 pprOpReg name op1 reg2
1782 pprOperand wordSize op1,
1784 pprReg wordSize reg2
1787 pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc
1788 pprCondRegReg name size cond reg1 reg2
1799 pprSizeSizeRegReg :: LitString -> Size -> Size -> Reg -> Reg -> Doc
1800 pprSizeSizeRegReg name size1 size2 reg1 reg2
1813 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1814 pprSizeRegRegReg name size reg1 reg2 reg3
1816 pprMnemonic name size,
1824 pprSizeAddrReg :: LitString -> Size -> AddrMode -> Reg -> Doc
1825 pprSizeAddrReg name size op dst
1827 pprMnemonic name size,
1833 pprSizeRegAddr :: LitString -> Size -> Reg -> AddrMode -> Doc
1834 pprSizeRegAddr name size src op
1836 pprMnemonic name size,
1842 pprShift :: LitString -> Size -> Operand -> Operand -> Doc
1843 pprShift name size src dest
1845 pprMnemonic name size,
1846 pprOperand II8 src, -- src is 8-bit sized
1848 pprOperand size dest
1851 pprSizeOpOpCoerce :: LitString -> Size -> Size -> Operand -> Operand -> Doc
1852 pprSizeOpOpCoerce name size1 size2 op1 op2
1853 = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
1854 pprOperand size1 op1,
1856 pprOperand size2 op2
1859 pprCondInstr :: LitString -> Cond -> Doc -> Doc
1860 pprCondInstr name cond arg
1861 = hcat [ char '\t', ptext name, pprCond cond, space, arg]
1863 #endif /* i386_TARGET_ARCH */
1866 -- ------------------------------------------------------------------------------- pprInstr for a SPARC
1868 #if sparc_TARGET_ARCH
1870 -- a clumsy hack for now, to handle possible double alignment problems
1872 -- even clumsier, to allow for RegReg regs that show when doing indexed
1873 -- reads (bytearrays).
1876 pprInstr (SPILL reg slot)
1878 ptext (sLit "\tSPILL"),
1882 ptext (sLit "SLOT") <> parens (int slot)]
1884 pprInstr (RELOAD slot reg)
1886 ptext (sLit "\tRELOAD"),
1888 ptext (sLit "SLOT") <> parens (int slot),
1892 -- Translate to the following:
1895 -- ld [g1+4],%f(n+1)
1896 -- sub g1,g2,g1 -- to restore g1
1898 pprInstr (LD FF64 (AddrRegReg g1 g2) reg)
1899 = let Just regH = fPair reg
1901 hcat [ptext (sLit "\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1902 hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg],
1903 hcat [pp_ld_lbracket, pprReg g1, ptext (sLit "+4]"), comma, pprReg regH],
1904 hcat [ptext (sLit "\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1909 -- ld [addr+4],%f(n+1)
1910 pprInstr (LD FF64 addr reg)
1911 = let Just addr2 = addrOffset addr 4
1912 Just regH = fPair reg
1914 hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
1915 hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg regH]
1919 pprInstr (LD size addr reg)
1921 ptext (sLit "\tld"),
1930 -- The same clumsy hack as above
1932 -- Translate to the following:
1935 -- st %f(n+1),[g1+4]
1936 -- sub g1,g2,g1 -- to restore g1
1937 pprInstr (ST FF64 reg (AddrRegReg g1 g2))
1938 = let Just regH = fPair reg
1940 hcat [ptext (sLit "\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1941 hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket,
1943 hcat [ptext (sLit "\tst\t"), pprReg regH, pp_comma_lbracket,
1944 pprReg g1, ptext (sLit "+4]")],
1945 hcat [ptext (sLit "\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1950 -- st %f(n+1),[addr+4]
1951 pprInstr instr@(ST FF64 reg addr)
1952 = let Just addr2 = addrOffset addr 4
1953 Just regH = fPair reg
1955 hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket,
1956 pprAddr addr, rbrack],
1957 hcat [ptext (sLit "\tst\t"), pprReg regH, pp_comma_lbracket,
1958 pprAddr addr2, rbrack]
1963 -- no distinction is made between signed and unsigned bytes on stores for the
1964 -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
1965 -- so we call a special-purpose pprSize for ST..
1967 pprInstr (ST size reg addr)
1969 ptext (sLit "\tst"),
1978 pprInstr (ADD x cc reg1 ri reg2)
1979 | not x && not cc && riZero ri
1980 = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1983 = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2
1985 pprInstr (SUB x cc reg1 ri reg2)
1986 | not x && cc && reg2 == g0
1987 = hcat [ ptext (sLit "\tcmp\t"), pprReg reg1, comma, pprRI ri ]
1988 | not x && not cc && riZero ri
1989 = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1991 = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2
1993 pprInstr (AND b reg1 ri reg2) = pprRegRIReg (sLit "and") b reg1 ri reg2
1994 pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2
1996 pprInstr (OR b reg1 ri reg2)
1997 | not b && reg1 == g0
1998 = let doit = hcat [ ptext (sLit "\tmov\t"), pprRI ri, comma, pprReg reg2 ]
2000 RIReg rrr | rrr == reg2 -> empty
2004 = pprRegRIReg (sLit "or") b reg1 ri reg2
2006 pprInstr (ORN b reg1 ri reg2) = pprRegRIReg (sLit "orn") b reg1 ri reg2
2008 pprInstr (XOR b reg1 ri reg2) = pprRegRIReg (sLit "xor") b reg1 ri reg2
2009 pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg (sLit "xnor") b reg1 ri reg2
2011 pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") False reg1 ri reg2
2012 pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") False reg1 ri reg2
2013 pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") False reg1 ri reg2
2015 pprInstr (RDY rd) = ptext (sLit "\trd\t%y,") <> pprReg rd
2016 pprInstr (WRY reg1 reg2)
2017 = ptext (sLit "\twr\t")
2022 <> ptext (sLit "%y")
2024 pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul") b reg1 ri reg2
2025 pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul") b reg1 ri reg2
2026 pprInstr (SDIV b reg1 ri reg2) = pprRegRIReg (sLit "sdiv") b reg1 ri reg2
2027 pprInstr (UDIV b reg1 ri reg2) = pprRegRIReg (sLit "udiv") b reg1 ri reg2
2029 pprInstr (SETHI imm reg)
2031 ptext (sLit "\tsethi\t"),
2037 pprInstr NOP = ptext (sLit "\tnop")
2039 pprInstr (FABS FF32 reg1 reg2) = pprSizeRegReg (sLit "fabs") FF32 reg1 reg2
2040 pprInstr (FABS FF64 reg1 reg2)
2041 = let Just reg1H = fPair reg1
2042 Just reg2H = fPair reg2
2044 (<>) (pprSizeRegReg (sLit "fabs") FF32 reg1 reg2)
2045 (if (reg1 == reg2) then empty
2046 else (<>) (char '\n')
2047 (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
2049 pprInstr (FADD size reg1 reg2 reg3)
2050 = pprSizeRegRegReg (sLit "fadd") size reg1 reg2 reg3
2051 pprInstr (FCMP e size reg1 reg2)
2052 = pprSizeRegReg (if e then sLit "fcmpe" else sLit "fcmp") size reg1 reg2
2053 pprInstr (FDIV size reg1 reg2 reg3)
2054 = pprSizeRegRegReg (sLit "fdiv") size reg1 reg2 reg3
2056 pprInstr (FMOV FF32 reg1 reg2) = pprSizeRegReg (sLit "fmov") FF32 reg1 reg2
2057 pprInstr (FMOV FF64 reg1 reg2) = pprSizeRegReg (sLit "fmov") FF64 reg1 reg2
2060 pprInstr (FMOV FF64 reg1 reg2)
2061 = let Just reg1H = fPair reg1
2062 Just reg2H = fPair reg2
2064 (<>) (pprSizeRegReg (sLit "fmov") FF32 reg1 reg2)
2065 (if (reg1 == reg2) then empty
2066 else (<>) (char '\n')
2067 (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
2070 pprInstr (FMUL size reg1 reg2 reg3)
2071 = pprSizeRegRegReg (sLit "fmul") size reg1 reg2 reg3
2073 pprInstr (FNEG FF32 reg1 reg2) = pprSizeRegReg (sLit "fneg") FF32 reg1 reg2
2074 pprInstr (FNEG FF64 reg1 reg2)
2075 = let Just reg1H = fPair reg1
2076 Just reg2H = fPair reg2
2078 (<>) (pprSizeRegReg (sLit "fneg") FF32 reg1 reg2)
2079 (if (reg1 == reg2) then empty
2080 else (<>) (char '\n')
2081 (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
2083 pprInstr (FSQRT size reg1 reg2) = pprSizeRegReg (sLit "fsqrt") size reg1 reg2
2084 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fsub") size reg1 reg2 reg3
2085 pprInstr (FxTOy size1 size2 reg1 reg2)
2092 FF64 -> sLit "dto"),
2098 FF64 -> sLit "d\t"),
2099 pprReg reg1, comma, pprReg reg2
2103 pprInstr (BI cond b (BlockId id))
2105 ptext (sLit "\tb"), pprCond cond,
2106 if b then pp_comma_a else empty,
2108 pprCLabel_asm (mkAsmTempLabel id)
2111 pprInstr (BF cond b (BlockId id))
2113 ptext (sLit "\tfb"), pprCond cond,
2114 if b then pp_comma_a else empty,
2116 pprCLabel_asm (mkAsmTempLabel id)
2119 pprInstr (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr addr)
2120 pprInstr (JMP_TBL op ids) = pprInstr (JMP op)
2122 pprInstr (CALL (Left imm) n _)
2123 = hcat [ ptext (sLit "\tcall\t"), pprImm imm, comma, int n ]
2124 pprInstr (CALL (Right reg) n _)
2125 = hcat [ ptext (sLit "\tcall\t"), pprReg reg, comma, int n ]
2128 pprRI (RIReg r) = pprReg r
2129 pprRI (RIImm r) = pprImm r
2131 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
2132 pprSizeRegReg name size reg1 reg2
2137 FF32 -> ptext (sLit "s\t")
2138 FF64 -> ptext (sLit "d\t")),
2144 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
2145 pprSizeRegRegReg name size reg1 reg2 reg3
2150 FF32 -> ptext (sLit "s\t")
2151 FF64 -> ptext (sLit "d\t")),
2159 pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
2160 pprRegRIReg name b reg1 ri reg2
2164 if b then ptext (sLit "cc\t") else char '\t',
2172 pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
2173 pprRIReg name b ri reg1
2177 if b then ptext (sLit "cc\t") else char '\t',
2183 pp_ld_lbracket = ptext (sLit "\tld\t[")
2184 pp_rbracket_comma = text "],"
2185 pp_comma_lbracket = text ",["
2186 pp_comma_a = text ",a"
2188 #endif /* sparc_TARGET_ARCH */
2191 -- -----------------------------------------------------------------------------
2192 -- pprInstr for PowerPC
2194 #if powerpc_TARGET_ARCH
2196 pprInstr (SPILL reg slot)
2198 ptext (sLit "\tSPILL"),
2202 ptext (sLit "SLOT") <> parens (int slot)]
2204 pprInstr (RELOAD slot reg)
2206 ptext (sLit "\tRELOAD"),
2208 ptext (sLit "SLOT") <> parens (int slot),
2212 pprInstr (LD sz reg addr) = hcat [
2221 case addr of AddrRegImm _ _ -> empty
2222 AddrRegReg _ _ -> char 'x',
2228 pprInstr (LA sz reg addr) = hcat [
2237 case addr of AddrRegImm _ _ -> empty
2238 AddrRegReg _ _ -> char 'x',
2244 pprInstr (ST sz reg addr) = hcat [
2248 case addr of AddrRegImm _ _ -> empty
2249 AddrRegReg _ _ -> char 'x',
2255 pprInstr (STU sz reg addr) = hcat [
2260 case addr of AddrRegImm _ _ -> empty
2261 AddrRegReg _ _ -> char 'x',
2266 pprInstr (LIS reg imm) = hcat [
2274 pprInstr (LI reg imm) = hcat [
2282 pprInstr (MR reg1 reg2)
2283 | reg1 == reg2 = empty
2284 | otherwise = hcat [
2286 case regClass reg1 of
2287 RcInteger -> ptext (sLit "mr")
2288 _ -> ptext (sLit "fmr"),
2294 pprInstr (CMP sz reg ri) = hcat [
2310 pprInstr (CMPL sz reg ri) = hcat [
2320 ptext (sLit "cmpl"),
2326 pprInstr (BCC cond (BlockId id)) = hcat [
2333 where lbl = mkAsmTempLabel id
2335 pprInstr (BCCFAR cond (BlockId id)) = vcat [
2338 pprCond (condNegate cond),
2339 ptext (sLit "\t$+8")
2342 ptext (sLit "\tb\t"),
2346 where lbl = mkAsmTempLabel id
2348 pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
2355 pprInstr (MTCTR reg) = hcat [
2357 ptext (sLit "mtctr"),
2361 pprInstr (BCTR _) = hcat [
2365 pprInstr (BL lbl _) = hcat [
2366 ptext (sLit "\tbl\t"),
2369 pprInstr (BCTRL _) = hcat [
2371 ptext (sLit "bctrl")
2373 pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri
2374 pprInstr (ADDIS reg1 reg2 imm) = hcat [
2376 ptext (sLit "addis"),
2385 pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3)
2386 pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3)
2387 pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3)
2388 pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri
2389 pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri
2390 pprInstr (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3)
2391 pprInstr (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3)
2393 pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
2394 hcat [ ptext (sLit "\tmullwo\t"), pprReg reg1, ptext (sLit ", "),
2395 pprReg reg2, ptext (sLit ", "),
2397 hcat [ ptext (sLit "\tmfxer\t"), pprReg reg1 ],
2398 hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "),
2399 pprReg reg1, ptext (sLit ", "),
2400 ptext (sLit "2, 31, 31") ]
2403 -- for some reason, "andi" doesn't exist.
2404 -- we'll use "andi." instead.
2405 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
2407 ptext (sLit "andi."),
2415 pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri
2417 pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri
2418 pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri
2420 pprInstr (XORIS reg1 reg2 imm) = hcat [
2422 ptext (sLit "xoris"),
2431 pprInstr (EXTS sz reg1 reg2) = hcat [
2433 ptext (sLit "exts"),
2441 pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2
2442 pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2
2444 pprInstr (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri)
2445 pprInstr (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri)
2446 pprInstr (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri)
2447 pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
2448 ptext (sLit "\trlwinm\t"),
2460 pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF (sLit "fadd") sz reg1 reg2 reg3
2461 pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF (sLit "fsub") sz reg1 reg2 reg3
2462 pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF (sLit "fmul") sz reg1 reg2 reg3
2463 pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") sz reg1 reg2 reg3
2464 pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2
2466 pprInstr (FCMP reg1 reg2) = hcat [
2468 ptext (sLit "fcmpu\tcr0, "),
2469 -- Note: we're using fcmpu, not fcmpo
2470 -- The difference is with fcmpo, compare with NaN is an invalid operation.
2471 -- We don't handle invalid fp ops, so we don't care
2477 pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2
2478 pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2
2480 pprInstr (CRNOR dst src1 src2) = hcat [
2481 ptext (sLit "\tcrnor\t"),
2489 pprInstr (MFCR reg) = hcat [
2491 ptext (sLit "mfcr"),
2496 pprInstr (MFLR reg) = hcat [
2498 ptext (sLit "mflr"),
2503 pprInstr (FETCHPC reg) = vcat [
2504 ptext (sLit "\tbcl\t20,31,1f"),
2505 hcat [ ptext (sLit "1:\tmflr\t"), pprReg reg ]
2508 pprInstr LWSYNC = ptext (sLit "\tlwsync")
2510 pprInstr _ = panic "pprInstr (ppc)"
2512 pprLogic op reg1 reg2 ri = hcat [
2517 RIImm _ -> char 'i',
2526 pprUnary op reg1 reg2 = hcat [
2535 pprBinaryF op sz reg1 reg2 reg3 = hcat [
2548 pprRI (RIReg r) = pprReg r
2549 pprRI (RIImm r) = pprImm r
2551 pprFSize FF64 = empty
2552 pprFSize FF32 = char 's'
2554 -- limit immediate argument for shift instruction to range 0..32
2555 -- (yes, the maximum is really 32, not 31)
2556 limitShiftRI :: RI -> RI
2557 limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32)
2560 #endif /* powerpc_TARGET_ARCH */
2563 -- -----------------------------------------------------------------------------
2564 -- Converting floating-point literals to integrals for printing
2566 castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)
2567 castFloatToWord8Array = castSTUArray
2569 castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8)
2570 castDoubleToWord8Array = castSTUArray
2572 -- floatToBytes and doubleToBytes convert to the host's byte
2573 -- order. Providing that we're not cross-compiling for a
2574 -- target with the opposite endianness, this should work ok
2577 -- ToDo: this stuff is very similar to the shenanigans in PprAbs,
2578 -- could they be merged?
2580 floatToBytes :: Float -> [Int]
2583 arr <- newArray_ ((0::Int),3)
2585 arr <- castFloatToWord8Array arr
2586 i0 <- readArray arr 0
2587 i1 <- readArray arr 1
2588 i2 <- readArray arr 2
2589 i3 <- readArray arr 3
2590 return (map fromIntegral [i0,i1,i2,i3])
2593 doubleToBytes :: Double -> [Int]
2596 arr <- newArray_ ((0::Int),7)
2598 arr <- castDoubleToWord8Array arr
2599 i0 <- readArray arr 0
2600 i1 <- readArray arr 1
2601 i2 <- readArray arr 2
2602 i3 <- readArray arr 3
2603 i4 <- readArray arr 4
2604 i5 <- readArray arr 5
2605 i6 <- readArray arr 6
2606 i7 <- readArray arr 7
2607 return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7])