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 ".skip ") <> int bytes
697 pprData (CmmStaticLit lit) = pprDataItem lit
699 pprGloblDecl :: CLabel -> Doc
701 | not (externallyVisibleCLabel lbl) = empty
702 | otherwise = ptext IF_ARCH_sparc((sLit ".global "),
706 pprTypeAndSizeDecl :: CLabel -> Doc
707 pprTypeAndSizeDecl lbl
709 | not (externallyVisibleCLabel lbl) = empty
710 | otherwise = ptext (sLit ".type ") <>
711 pprCLabel_asm lbl <> ptext (sLit ", @object")
716 pprLabel :: CLabel -> Doc
717 pprLabel lbl = pprGloblDecl lbl $$ pprTypeAndSizeDecl lbl $$ (pprCLabel_asm lbl <> char ':')
721 = vcat (map do1 str) $$ do1 0
724 do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w)
727 IF_ARCH_alpha(ptext (sLit ".align ") <> int pow2,
728 IF_ARCH_i386(ptext (sLit ".align ") <> int IF_OS_darwin(pow2,bytes),
729 IF_ARCH_x86_64(ptext (sLit ".align ") <> int IF_OS_darwin(pow2,bytes),
730 IF_ARCH_sparc(ptext (sLit ".align ") <> int bytes,
731 IF_ARCH_powerpc(ptext (sLit ".align ") <> int pow2,)))))
735 log2 :: Int -> Int -- cache the common ones
740 log2 n = 1 + log2 (n `quot` 2)
743 pprDataItem :: CmmLit -> Doc
745 = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit)
749 -- These seem to be common:
750 ppr_item II8 x = [ptext (sLit "\t.byte\t") <> pprImm imm]
751 ppr_item II32 x = [ptext (sLit "\t.long\t") <> pprImm imm]
752 ppr_item FF32 (CmmFloat r _)
753 = let bs = floatToBytes (fromRational r)
754 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
755 ppr_item FF64 (CmmFloat r _)
756 = let bs = doubleToBytes (fromRational r)
757 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
759 #if sparc_TARGET_ARCH
760 -- copy n paste of x86 version
761 ppr_item II16 x = [ptext (sLit "\t.short\t") <> pprImm imm]
762 ppr_item II64 x = [ptext (sLit "\t.quad\t") <> pprImm imm]
764 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
765 ppr_item II16 x = [ptext (sLit "\t.word\t") <> pprImm imm]
767 #if i386_TARGET_ARCH && darwin_TARGET_OS
768 ppr_item II64 (CmmInt x _) =
769 [ptext (sLit "\t.long\t")
770 <> int (fromIntegral (fromIntegral x :: Word32)),
771 ptext (sLit "\t.long\t")
773 (fromIntegral (x `shiftR` 32) :: Word32))]
775 #if i386_TARGET_ARCH || (darwin_TARGET_OS && x86_64_TARGET_ARCH)
776 ppr_item II64 x = [ptext (sLit "\t.quad\t") <> pprImm imm]
778 #if x86_64_TARGET_ARCH && !darwin_TARGET_OS
779 -- x86_64: binutils can't handle the R_X86_64_PC64 relocation
780 -- type, which means we can't do pc-relative 64-bit addresses.
781 -- Fortunately we're assuming the small memory model, in which
782 -- all such offsets will fit into 32 bits, so we have to stick
783 -- to 32-bit offset fields and modify the RTS appropriately
785 -- See Note [x86-64-relative] in includes/InfoTables.h
788 | isRelativeReloc x =
789 [ptext (sLit "\t.long\t") <> pprImm imm,
790 ptext (sLit "\t.long\t0")]
792 [ptext (sLit "\t.quad\t") <> pprImm imm]
794 isRelativeReloc (CmmLabelDiffOff _ _ _) = True
795 isRelativeReloc _ = False
797 #if powerpc_TARGET_ARCH
798 ppr_item II16 x = [ptext (sLit "\t.short\t") <> pprImm imm]
799 ppr_item II64 (CmmInt x _) =
800 [ptext (sLit "\t.long\t")
802 (fromIntegral (x `shiftR` 32) :: Word32)),
803 ptext (sLit "\t.long\t")
804 <> int (fromIntegral (fromIntegral x :: Word32))]
807 -- fall through to rest of (machine-specific) pprInstr...
809 -- -----------------------------------------------------------------------------
810 -- pprInstr: print an 'Instr'
812 instance Outputable Instr where
813 ppr instr = Outputable.docToSDoc $ pprInstr instr
815 pprInstr :: Instr -> Doc
817 pprInstr (COMMENT s) = empty -- nuke 'em
820 = IF_ARCH_alpha( ((<>) (ptext (sLit "\t# ")) (ftext s))
821 ,IF_ARCH_sparc( ((<>) (ptext (sLit "# ")) (ftext s))
822 ,IF_ARCH_i386( ((<>) (ptext (sLit "# ")) (ftext s))
823 ,IF_ARCH_x86_64( ((<>) (ptext (sLit "# ")) (ftext s))
824 ,IF_ARCH_powerpc( IF_OS_linux(
825 ((<>) (ptext (sLit "# ")) (ftext s)),
826 ((<>) (ptext (sLit "; ")) (ftext s)))
830 = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
832 pprInstr (NEWBLOCK _)
833 = panic "PprMach.pprInstr: NEWBLOCK"
836 = panic "PprMach.pprInstr: LDATA"
838 -- -----------------------------------------------------------------------------
839 -- pprInstr for an Alpha
841 #if alpha_TARGET_ARCH
843 pprInstr (SPILL reg slot)
845 ptext (sLit "\tSPILL"),
849 ptext (sLit "SLOT") <> parens (int slot)]
851 pprInstr (RELOAD slot reg)
853 ptext (sLit "\tRELOAD"),
855 ptext (sLit "SLOT") <> parens (int slot),
859 pprInstr (LD size reg addr)
869 pprInstr (LDA reg addr)
871 ptext (sLit "\tlda\t"),
877 pprInstr (LDAH reg addr)
879 ptext (sLit "\tldah\t"),
885 pprInstr (LDGP reg addr)
887 ptext (sLit "\tldgp\t"),
893 pprInstr (LDI size reg imm)
895 ptext (sLit "\tldi"),
903 pprInstr (ST size reg addr)
915 ptext (sLit "\tclr\t"),
919 pprInstr (ABS size ri reg)
921 ptext (sLit "\tabs"),
929 pprInstr (NEG size ov ri reg)
931 ptext (sLit "\tneg"),
933 if ov then ptext (sLit "v\t") else char '\t',
939 pprInstr (ADD size ov reg1 ri reg2)
941 ptext (sLit "\tadd"),
943 if ov then ptext (sLit "v\t") else char '\t',
951 pprInstr (SADD size scale reg1 ri reg2)
953 ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
964 pprInstr (SUB size ov reg1 ri reg2)
966 ptext (sLit "\tsub"),
968 if ov then ptext (sLit "v\t") else char '\t',
976 pprInstr (SSUB size scale reg1 ri reg2)
978 ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
989 pprInstr (MUL size ov reg1 ri reg2)
991 ptext (sLit "\tmul"),
993 if ov then ptext (sLit "v\t") else char '\t',
1001 pprInstr (DIV size uns reg1 ri reg2)
1003 ptext (sLit "\tdiv"),
1005 if uns then ptext (sLit "u\t") else char '\t',
1013 pprInstr (REM size uns reg1 ri reg2)
1015 ptext (sLit "\trem"),
1017 if uns then ptext (sLit "u\t") else char '\t',
1025 pprInstr (NOT ri reg)
1027 ptext (sLit "\tnot"),
1034 pprInstr (AND reg1 ri reg2) = pprRegRIReg (sLit "and") reg1 ri reg2
1035 pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg (sLit "andnot") reg1 ri reg2
1036 pprInstr (OR reg1 ri reg2) = pprRegRIReg (sLit "or") reg1 ri reg2
1037 pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg (sLit "ornot") reg1 ri reg2
1038 pprInstr (XOR reg1 ri reg2) = pprRegRIReg (sLit "xor") reg1 ri reg2
1039 pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg (sLit "xornot") reg1 ri reg2
1041 pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") reg1 ri reg2
1042 pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") reg1 ri reg2
1043 pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") reg1 ri reg2
1045 pprInstr (ZAP reg1 ri reg2) = pprRegRIReg (sLit "zap") reg1 ri reg2
1046 pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg (sLit "zapnot") reg1 ri reg2
1048 pprInstr (NOP) = ptext (sLit "\tnop")
1050 pprInstr (CMP cond reg1 ri reg2)
1052 ptext (sLit "\tcmp"),
1064 ptext (sLit "\tfclr\t"),
1068 pprInstr (FABS reg1 reg2)
1070 ptext (sLit "\tfabs\t"),
1076 pprInstr (FNEG size reg1 reg2)
1078 ptext (sLit "\tneg"),
1086 pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "add") size reg1 reg2 reg3
1087 pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "div") size reg1 reg2 reg3
1088 pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "mul") size reg1 reg2 reg3
1089 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "sub") size reg1 reg2 reg3
1091 pprInstr (CVTxy size1 size2 reg1 reg2)
1093 ptext (sLit "\tcvt"),
1095 case size2 of {Q -> ptext (sLit "qc"); _ -> pprSize size2},
1102 pprInstr (FCMP size cond reg1 reg2 reg3)
1104 ptext (sLit "\tcmp"),
1115 pprInstr (FMOV reg1 reg2)
1117 ptext (sLit "\tfmov\t"),
1123 pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
1125 pprInstr (BI NEVER reg lab) = empty
1127 pprInstr (BI cond reg lab)
1137 pprInstr (BF cond reg lab)
1139 ptext (sLit "\tfb"),
1148 = (<>) (ptext (sLit "\tbr\t")) (pprImm lab)
1150 pprInstr (JMP reg addr hint)
1152 ptext (sLit "\tjmp\t"),
1160 pprInstr (BSR imm n)
1161 = (<>) (ptext (sLit "\tbsr\t")) (pprImm imm)
1163 pprInstr (JSR reg addr n)
1165 ptext (sLit "\tjsr\t"),
1171 pprInstr (FUNBEGIN clab)
1173 if (externallyVisibleCLabel clab) then
1174 hcat [ptext (sLit "\t.globl\t"), pp_lab, char '\n']
1177 ptext (sLit "\t.ent "),
1186 pp_lab = pprCLabel_asm clab
1188 -- NEVER use commas within those string literals, cpp will ruin your day
1189 pp_ldgp = hcat [ ptext (sLit ":\n\tldgp $29"), char ',', ptext (sLit "0($27)\n") ]
1190 pp_frame = hcat [ ptext (sLit "..ng:\n\t.frame $30"), char ',',
1191 ptext (sLit "4240"), char ',',
1192 ptext (sLit "$26"), char ',',
1193 ptext (sLit "0\n\t.prologue 1") ]
1195 pprInstr (FUNEND clab)
1196 = (<>) (ptext (sLit "\t.align 4\n\t.end ")) (pprCLabel_asm clab)
1199 Continue with Alpha-only printing bits and bobs:
1203 pprRI (RIReg r) = pprReg r
1204 pprRI (RIImm r) = pprImm r
1206 pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
1207 pprRegRIReg name reg1 ri reg2
1219 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1220 pprSizeRegRegReg name size reg1 reg2 reg3
1233 #endif /* alpha_TARGET_ARCH */
1236 -- -----------------------------------------------------------------------------
1237 -- pprInstr for an x86
1239 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1241 pprInstr (SPILL reg slot)
1243 ptext (sLit "\tSPILL"),
1247 ptext (sLit "SLOT") <> parens (int slot)]
1249 pprInstr (RELOAD slot reg)
1251 ptext (sLit "\tRELOAD"),
1253 ptext (sLit "SLOT") <> parens (int slot),
1257 pprInstr (MOV size src dst)
1258 = pprSizeOpOp (sLit "mov") size src dst
1260 pprInstr (MOVZxL II32 src dst) = pprSizeOpOp (sLit "mov") II32 src dst
1261 -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple
1262 -- movl. But we represent it as a MOVZxL instruction, because
1263 -- the reg alloc would tend to throw away a plain reg-to-reg
1264 -- move, and we still want it to do that.
1266 pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce (sLit "movz") sizes II32 src dst
1267 -- zero-extension only needs to extend to 32 bits: on x86_64,
1268 -- the remaining zero-extension to 64 bits is automatic, and the 32-bit
1269 -- instruction is shorter.
1271 pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce (sLit "movs") sizes wordSize src dst
1273 -- here we do some patching, since the physical registers are only set late
1274 -- in the code generation.
1275 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1277 = pprSizeOpOp (sLit "add") size (OpReg reg2) dst
1278 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1280 = pprSizeOpOp (sLit "add") size (OpReg reg1) dst
1281 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))
1283 = pprInstr (ADD size (OpImm displ) dst)
1284 pprInstr (LEA size src dst) = pprSizeOpOp (sLit "lea") size src dst
1286 pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
1287 = pprSizeOp (sLit "dec") size dst
1288 pprInstr (ADD size (OpImm (ImmInt 1)) dst)
1289 = pprSizeOp (sLit "inc") size dst
1290 pprInstr (ADD size src dst)
1291 = pprSizeOpOp (sLit "add") size src dst
1292 pprInstr (ADC size src dst)
1293 = pprSizeOpOp (sLit "adc") size src dst
1294 pprInstr (SUB size src dst) = pprSizeOpOp (sLit "sub") size src dst
1295 pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2
1297 {- A hack. The Intel documentation says that "The two and three
1298 operand forms [of IMUL] may also be used with unsigned operands
1299 because the lower half of the product is the same regardless if
1300 (sic) the operands are signed or unsigned. The CF and OF flags,
1301 however, cannot be used to determine if the upper half of the
1302 result is non-zero." So there.
1304 pprInstr (AND size src dst) = pprSizeOpOp (sLit "and") size src dst
1305 pprInstr (OR size src dst) = pprSizeOpOp (sLit "or") size src dst
1307 pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst
1308 pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst
1309 pprInstr (XOR size src dst) = pprSizeOpOp (sLit "xor") size src dst
1311 pprInstr (NOT size op) = pprSizeOp (sLit "not") size op
1312 pprInstr (NEGI size op) = pprSizeOp (sLit "neg") size op
1314 pprInstr (SHL size src dst) = pprShift (sLit "shl") size src dst
1315 pprInstr (SAR size src dst) = pprShift (sLit "sar") size src dst
1316 pprInstr (SHR size src dst) = pprShift (sLit "shr") size src dst
1318 pprInstr (BT size imm src) = pprSizeImmOp (sLit "bt") size imm src
1320 pprInstr (CMP size src dst)
1321 | is_float size = pprSizeOpOp (sLit "ucomi") size src dst -- SSE2
1322 | otherwise = pprSizeOpOp (sLit "cmp") size src dst
1324 -- This predicate is needed here and nowhere else
1325 is_float FF32 = True
1326 is_float FF64 = True
1327 is_float FF80 = True
1328 is_float other = False
1330 pprInstr (TEST size src dst) = pprSizeOpOp (sLit "test") size src dst
1331 pprInstr (PUSH size op) = pprSizeOp (sLit "push") size op
1332 pprInstr (POP size op) = pprSizeOp (sLit "pop") size op
1334 -- both unused (SDM):
1335 -- pprInstr PUSHA = ptext (sLit "\tpushal")
1336 -- pprInstr POPA = ptext (sLit "\tpopal")
1338 pprInstr NOP = ptext (sLit "\tnop")
1339 pprInstr (CLTD II32) = ptext (sLit "\tcltd")
1340 pprInstr (CLTD II64) = ptext (sLit "\tcqto")
1342 pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op)
1344 pprInstr (JXX cond (BlockId id))
1345 = pprCondInstr (sLit "j") cond (pprCLabel_asm lab)
1346 where lab = mkAsmTempLabel id
1348 pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm)
1350 pprInstr (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm)
1351 pprInstr (JMP op) = (<>) (ptext (sLit "\tjmp *")) (pprOperand wordSize op)
1352 pprInstr (JMP_TBL op ids) = pprInstr (JMP op)
1353 pprInstr (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm)
1354 pprInstr (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg wordSize reg)
1356 pprInstr (IDIV sz op) = pprSizeOp (sLit "idiv") sz op
1357 pprInstr (DIV sz op) = pprSizeOp (sLit "div") sz op
1358 pprInstr (IMUL2 sz op) = pprSizeOp (sLit "imul") sz op
1360 #if x86_64_TARGET_ARCH
1361 pprInstr (MUL size op1 op2) = pprSizeOpOp (sLit "mul") size op1 op2
1363 pprInstr (FDIV size op1 op2) = pprSizeOpOp (sLit "div") size op1 op2
1365 pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to
1366 pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to
1367 pprInstr (CVTTSS2SIQ from to) = pprOpReg (sLit "cvttss2siq") from to
1368 pprInstr (CVTTSD2SIQ from to) = pprOpReg (sLit "cvttsd2siq") from to
1369 pprInstr (CVTSI2SS from to) = pprOpReg (sLit "cvtsi2ssq") from to
1370 pprInstr (CVTSI2SD from to) = pprOpReg (sLit "cvtsi2sdq") from to
1373 -- FETCHGOT for PIC on ELF platforms
1374 pprInstr (FETCHGOT reg)
1375 = vcat [ ptext (sLit "\tcall 1f"),
1376 hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ],
1377 hcat [ ptext (sLit "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "),
1381 -- FETCHPC for PIC on Darwin/x86
1382 -- get the instruction pointer into a register
1383 -- (Terminology note: the IP is called Program Counter on PPC,
1384 -- and it's a good thing to use the same name on both platforms)
1385 pprInstr (FETCHPC reg)
1386 = vcat [ ptext (sLit "\tcall 1f"),
1387 hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ]
1394 -- -----------------------------------------------------------------------------
1395 -- i386 floating-point
1397 #if i386_TARGET_ARCH
1398 -- Simulating a flat register set on the x86 FP stack is tricky.
1399 -- you have to free %st(7) before pushing anything on the FP reg stack
1400 -- so as to preclude the possibility of a FP stack overflow exception.
1401 pprInstr g@(GMOV src dst)
1405 = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
1407 -- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FSTP (dst+1)
1408 pprInstr g@(GLD sz addr dst)
1409 = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp,
1410 pprAddr addr, gsemi, gpop dst 1])
1412 -- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
1413 pprInstr g@(GST sz src addr)
1414 = pprG g (hcat [gtab, gpush src 0, gsemi,
1415 text "fstp", pprSize sz, gsp, pprAddr addr])
1417 pprInstr g@(GLDZ dst)
1418 = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1])
1419 pprInstr g@(GLD1 dst)
1420 = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1])
1422 pprInstr g@(GFTOI src dst)
1423 = pprInstr (GDTOI src dst)
1424 pprInstr g@(GDTOI src dst)
1426 hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"],
1427 hcat [gtab, gpush src 0],
1428 hcat [gtab, text "movzwl 4(%esp), ", reg,
1429 text " ; orl $0xC00, ", reg],
1430 hcat [gtab, text "movl ", reg, text ", 0(%esp) ; fldcw 0(%esp)"],
1431 hcat [gtab, text "fistpl 0(%esp)"],
1432 hcat [gtab, text "fldcw 4(%esp) ; movl 0(%esp), ", reg],
1433 hcat [gtab, text "addl $8, %esp"]
1436 reg = pprReg II32 dst
1438 pprInstr g@(GITOF src dst)
1439 = pprInstr (GITOD src dst)
1440 pprInstr g@(GITOD src dst)
1441 = pprG g (hcat [gtab, text "pushl ", pprReg II32 src,
1442 text " ; ffree %st(7); fildl (%esp) ; ",
1443 gpop dst 1, text " ; addl $4,%esp"])
1445 {- Gruesome swamp follows. If you're unfortunate enough to have ventured
1446 this far into the jungle AND you give a Rat's Ass (tm) what's going
1447 on, here's the deal. Generate code to do a floating point comparison
1448 of src1 and src2, of kind cond, and set the Zero flag if true.
1450 The complications are to do with handling NaNs correctly. We want the
1451 property that if either argument is NaN, then the result of the
1452 comparison is False ... except if we're comparing for inequality,
1453 in which case the answer is True.
1455 Here's how the general (non-inequality) case works. As an
1456 example, consider generating the an equality test:
1458 pushl %eax -- we need to mess with this
1459 <get src1 to top of FPU stack>
1460 fcomp <src2 location in FPU stack> and pop pushed src1
1461 -- Result of comparison is in FPU Status Register bits
1463 fstsw %ax -- Move FPU Status Reg to %ax
1464 sahf -- move C3 C2 C0 from %ax to integer flag reg
1465 -- now the serious magic begins
1466 setpo %ah -- %ah = if comparable(neither arg was NaN) then 1 else 0
1467 sete %al -- %al = if arg1 == arg2 then 1 else 0
1468 andb %ah,%al -- %al &= %ah
1469 -- so %al == 1 iff (comparable && same); else it holds 0
1470 decb %al -- %al == 0, ZeroFlag=1 iff (comparable && same);
1471 else %al == 0xFF, ZeroFlag=0
1472 -- the zero flag is now set as we desire.
1475 The special case of inequality differs thusly:
1477 setpe %ah -- %ah = if incomparable(either arg was NaN) then 1 else 0
1478 setne %al -- %al = if arg1 /= arg2 then 1 else 0
1479 orb %ah,%al -- %al = if (incomparable || different) then 1 else 0
1480 decb %al -- if (incomparable || different) then (%al == 0, ZF=1)
1481 else (%al == 0xFF, ZF=0)
1483 pprInstr g@(GCMP cond src1 src2)
1484 | case cond of { NE -> True; other -> False }
1486 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1487 hcat [gtab, text "fcomp ", greg src2 1,
1488 text "; fstsw %ax ; sahf ; setpe %ah"],
1489 hcat [gtab, text "setne %al ; ",
1490 text "orb %ah,%al ; decb %al ; popl %eax"]
1494 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1495 hcat [gtab, text "fcomp ", greg src2 1,
1496 text "; fstsw %ax ; sahf ; setpo %ah"],
1497 hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ; ",
1498 text "andb %ah,%al ; decb %al ; popl %eax"]
1501 {- On the 486, the flags set by FP compare are the unsigned ones!
1502 (This looks like a HACK to me. WDP 96/03)
1504 fix_FP_cond :: Cond -> Cond
1505 fix_FP_cond GE = GEU
1506 fix_FP_cond GTT = GU
1507 fix_FP_cond LTT = LU
1508 fix_FP_cond LE = LEU
1509 fix_FP_cond EQQ = EQQ
1511 -- there should be no others
1514 pprInstr g@(GABS sz src dst)
1515 = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
1516 pprInstr g@(GNEG sz src dst)
1517 = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
1519 pprInstr g@(GSQRT sz src dst)
1520 = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
1521 hcat [gtab, gcoerceto sz, gpop dst 1])
1522 pprInstr g@(GSIN sz l1 l2 src dst)
1523 = pprG g (pprTrigOp "fsin" False l1 l2 src dst sz)
1524 pprInstr g@(GCOS sz l1 l2 src dst)
1525 = pprG g (pprTrigOp "fcos" False l1 l2 src dst sz)
1526 pprInstr g@(GTAN sz l1 l2 src dst)
1527 = pprG g (pprTrigOp "fptan" True l1 l2 src dst sz)
1529 -- In the translations for GADD, GMUL, GSUB and GDIV,
1530 -- the first two cases are mere optimisations. The otherwise clause
1531 -- generates correct code under all circumstances.
1533 pprInstr g@(GADD sz src1 src2 dst)
1535 = pprG g (text "\t#GADD-xxxcase1" $$
1536 hcat [gtab, gpush src2 0,
1537 text " ; faddp %st(0),", greg src1 1])
1539 = pprG g (text "\t#GADD-xxxcase2" $$
1540 hcat [gtab, gpush src1 0,
1541 text " ; faddp %st(0),", greg src2 1])
1543 = pprG g (hcat [gtab, gpush src1 0,
1544 text " ; fadd ", greg src2 1, text ",%st(0)",
1548 pprInstr g@(GMUL sz src1 src2 dst)
1550 = pprG g (text "\t#GMUL-xxxcase1" $$
1551 hcat [gtab, gpush src2 0,
1552 text " ; fmulp %st(0),", greg src1 1])
1554 = pprG g (text "\t#GMUL-xxxcase2" $$
1555 hcat [gtab, gpush src1 0,
1556 text " ; fmulp %st(0),", greg src2 1])
1558 = pprG g (hcat [gtab, gpush src1 0,
1559 text " ; fmul ", greg src2 1, text ",%st(0)",
1563 pprInstr g@(GSUB sz src1 src2 dst)
1565 = pprG g (text "\t#GSUB-xxxcase1" $$
1566 hcat [gtab, gpush src2 0,
1567 text " ; fsubrp %st(0),", greg src1 1])
1569 = pprG g (text "\t#GSUB-xxxcase2" $$
1570 hcat [gtab, gpush src1 0,
1571 text " ; fsubp %st(0),", greg src2 1])
1573 = pprG g (hcat [gtab, gpush src1 0,
1574 text " ; fsub ", greg src2 1, text ",%st(0)",
1578 pprInstr g@(GDIV sz src1 src2 dst)
1580 = pprG g (text "\t#GDIV-xxxcase1" $$
1581 hcat [gtab, gpush src2 0,
1582 text " ; fdivrp %st(0),", greg src1 1])
1584 = pprG g (text "\t#GDIV-xxxcase2" $$
1585 hcat [gtab, gpush src1 0,
1586 text " ; fdivp %st(0),", greg src2 1])
1588 = pprG g (hcat [gtab, gpush src1 0,
1589 text " ; fdiv ", greg src2 1, text ",%st(0)",
1594 = vcat [ ptext (sLit "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
1595 ptext (sLit "\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)")
1598 pprTrigOp :: String -> Bool -> CLabel -> CLabel -> Reg -> Reg -> Size -> Doc
1599 pprTrigOp op -- fsin, fcos or fptan
1600 isTan -- we need a couple of extra steps if we're doing tan
1601 l1 l2 -- internal labels for us to use
1603 = -- We'll be needing %eax later on
1604 hcat [gtab, text "pushl %eax;"] $$
1605 -- tan is going to use an extra space on the FP stack
1606 (if isTan then hcat [gtab, text "ffree %st(6)"] else empty) $$
1607 -- First put the value in %st(0) and try to apply the op to it
1608 hcat [gpush src 0, text ("; " ++ op)] $$
1609 -- Now look to see if C2 was set (overflow, |value| >= 2^63)
1610 hcat [gtab, text "fnstsw %ax"] $$
1611 hcat [gtab, text "test $0x400,%eax"] $$
1612 -- If we were in bounds then jump to the end
1613 hcat [gtab, text "je " <> pprCLabel_asm l1] $$
1614 -- Otherwise we need to shrink the value. Start by
1615 -- loading pi, doubleing it (by adding it to itself),
1616 -- and then swapping pi with the value, so the value we
1617 -- want to apply op to is in %st(0) again
1618 hcat [gtab, text "ffree %st(7); fldpi"] $$
1619 hcat [gtab, text "fadd %st(0),%st"] $$
1620 hcat [gtab, text "fxch %st(1)"] $$
1621 -- Now we have a loop in which we make the value smaller,
1622 -- see if it's small enough, and loop if not
1623 (pprCLabel_asm l2 <> char ':') $$
1624 hcat [gtab, text "fprem1"] $$
1625 -- My Debian libc uses fstsw here for the tan code, but I can't
1626 -- see any reason why it should need to be different for tan.
1627 hcat [gtab, text "fnstsw %ax"] $$
1628 hcat [gtab, text "test $0x400,%eax"] $$
1629 hcat [gtab, text "jne " <> pprCLabel_asm l2] $$
1630 hcat [gtab, text "fstp %st(1)"] $$
1631 hcat [gtab, text op] $$
1632 (pprCLabel_asm l1 <> char ':') $$
1633 -- Pop the 1.0 tan gave us
1634 (if isTan then hcat [gtab, text "fstp %st(0)"] else empty) $$
1636 hcat [gtab, text "popl %eax;"] $$
1637 -- And finally make the result the right size
1638 hcat [gtab, gcoerceto sz, gpop dst 1]
1640 --------------------------
1642 -- coerce %st(0) to the specified size
1643 gcoerceto FF64 = empty
1644 gcoerceto FF32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
1647 = hcat [text "ffree %st(7) ; fld ", greg reg offset]
1649 = hcat [text "fstp ", greg reg offset]
1651 greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
1656 gregno (RealReg i) = i
1657 gregno other = --pprPanic "gregno" (ppr other)
1658 999 -- bogus; only needed for debug printing
1660 pprG :: Instr -> Doc -> Doc
1662 = (char '#' <> pprGInstr fake) $$ actual
1664 pprGInstr (GMOV src dst) = pprSizeRegReg (sLit "gmov") FF64 src dst
1665 pprGInstr (GLD sz src dst) = pprSizeAddrReg (sLit "gld") sz src dst
1666 pprGInstr (GST sz src dst) = pprSizeRegAddr (sLit "gst") sz src dst
1668 pprGInstr (GLDZ dst) = pprSizeReg (sLit "gldz") FF64 dst
1669 pprGInstr (GLD1 dst) = pprSizeReg (sLit "gld1") FF64 dst
1671 pprGInstr (GFTOI src dst) = pprSizeSizeRegReg (sLit "gftoi") FF32 II32 src dst
1672 pprGInstr (GDTOI src dst) = pprSizeSizeRegReg (sLit "gdtoi") FF64 II32 src dst
1674 pprGInstr (GITOF src dst) = pprSizeSizeRegReg (sLit "gitof") II32 FF32 src dst
1675 pprGInstr (GITOD src dst) = pprSizeSizeRegReg (sLit "gitod") II32 FF64 src dst
1677 pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 co src dst
1678 pprGInstr (GABS sz src dst) = pprSizeRegReg (sLit "gabs") sz src dst
1679 pprGInstr (GNEG sz src dst) = pprSizeRegReg (sLit "gneg") sz src dst
1680 pprGInstr (GSQRT sz src dst) = pprSizeRegReg (sLit "gsqrt") sz src dst
1681 pprGInstr (GSIN sz _ _ src dst) = pprSizeRegReg (sLit "gsin") sz src dst
1682 pprGInstr (GCOS sz _ _ src dst) = pprSizeRegReg (sLit "gcos") sz src dst
1683 pprGInstr (GTAN sz _ _ src dst) = pprSizeRegReg (sLit "gtan") sz src dst
1685 pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg (sLit "gadd") sz src1 src2 dst
1686 pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg (sLit "gsub") sz src1 src2 dst
1687 pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg (sLit "gmul") sz src1 src2 dst
1688 pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg (sLit "gdiv") sz src1 src2 dst
1691 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1693 -- Continue with I386-only printing bits and bobs:
1695 pprDollImm :: Imm -> Doc
1697 pprDollImm i = ptext (sLit "$") <> pprImm i
1699 pprOperand :: Size -> Operand -> Doc
1700 pprOperand s (OpReg r) = pprReg s r
1701 pprOperand s (OpImm i) = pprDollImm i
1702 pprOperand s (OpAddr ea) = pprAddr ea
1704 pprMnemonic_ :: LitString -> Doc
1706 char '\t' <> ptext name <> space
1708 pprMnemonic :: LitString -> Size -> Doc
1709 pprMnemonic name size =
1710 char '\t' <> ptext name <> pprSize size <> space
1712 pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc
1713 pprSizeImmOp name size imm op1
1715 pprMnemonic name size,
1722 pprSizeOp :: LitString -> Size -> Operand -> Doc
1723 pprSizeOp name size op1
1725 pprMnemonic name size,
1729 pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1730 pprSizeOpOp name size op1 op2
1732 pprMnemonic name size,
1733 pprOperand size op1,
1738 pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1739 pprOpOp name size op1 op2
1742 pprOperand size op1,
1747 pprSizeReg :: LitString -> Size -> Reg -> Doc
1748 pprSizeReg name size reg1
1750 pprMnemonic name size,
1754 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
1755 pprSizeRegReg name size reg1 reg2
1757 pprMnemonic name size,
1763 pprRegReg :: LitString -> Reg -> Reg -> Doc
1764 pprRegReg name reg1 reg2
1767 pprReg wordSize reg1,
1769 pprReg wordSize reg2
1772 pprOpReg :: LitString -> Operand -> Reg -> Doc
1773 pprOpReg name op1 reg2
1776 pprOperand wordSize op1,
1778 pprReg wordSize reg2
1781 pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc
1782 pprCondRegReg name size cond reg1 reg2
1793 pprSizeSizeRegReg :: LitString -> Size -> Size -> Reg -> Reg -> Doc
1794 pprSizeSizeRegReg name size1 size2 reg1 reg2
1807 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1808 pprSizeRegRegReg name size reg1 reg2 reg3
1810 pprMnemonic name size,
1818 pprSizeAddrReg :: LitString -> Size -> AddrMode -> Reg -> Doc
1819 pprSizeAddrReg name size op dst
1821 pprMnemonic name size,
1827 pprSizeRegAddr :: LitString -> Size -> Reg -> AddrMode -> Doc
1828 pprSizeRegAddr name size src op
1830 pprMnemonic name size,
1836 pprShift :: LitString -> Size -> Operand -> Operand -> Doc
1837 pprShift name size src dest
1839 pprMnemonic name size,
1840 pprOperand II8 src, -- src is 8-bit sized
1842 pprOperand size dest
1845 pprSizeOpOpCoerce :: LitString -> Size -> Size -> Operand -> Operand -> Doc
1846 pprSizeOpOpCoerce name size1 size2 op1 op2
1847 = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
1848 pprOperand size1 op1,
1850 pprOperand size2 op2
1853 pprCondInstr :: LitString -> Cond -> Doc -> Doc
1854 pprCondInstr name cond arg
1855 = hcat [ char '\t', ptext name, pprCond cond, space, arg]
1857 #endif /* i386_TARGET_ARCH */
1860 -- ------------------------------------------------------------------------------- pprInstr for a SPARC
1862 #if sparc_TARGET_ARCH
1864 -- a clumsy hack for now, to handle possible double alignment problems
1866 -- even clumsier, to allow for RegReg regs that show when doing indexed
1867 -- reads (bytearrays).
1870 pprInstr (SPILL reg slot)
1872 ptext (sLit "\tSPILL"),
1876 ptext (sLit "SLOT") <> parens (int slot)]
1878 pprInstr (RELOAD slot reg)
1880 ptext (sLit "\tRELOAD"),
1882 ptext (sLit "SLOT") <> parens (int slot),
1886 -- Translate to the following:
1889 -- ld [g1+4],%f(n+1)
1890 -- sub g1,g2,g1 -- to restore g1
1892 pprInstr (LD FF64 (AddrRegReg g1 g2) reg)
1893 = let Just regH = fPair reg
1895 hcat [ptext (sLit "\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1896 hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg],
1897 hcat [pp_ld_lbracket, pprReg g1, ptext (sLit "+4]"), comma, pprReg regH],
1898 hcat [ptext (sLit "\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1903 -- ld [addr+4],%f(n+1)
1904 pprInstr (LD FF64 addr reg)
1905 = let Just addr2 = addrOffset addr 4
1906 Just regH = fPair reg
1908 hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
1909 hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg regH]
1913 pprInstr (LD size addr reg)
1915 ptext (sLit "\tld"),
1924 -- The same clumsy hack as above
1926 -- Translate to the following:
1929 -- st %f(n+1),[g1+4]
1930 -- sub g1,g2,g1 -- to restore g1
1931 pprInstr (ST FF64 reg (AddrRegReg g1 g2))
1932 = let Just regH = fPair reg
1934 hcat [ptext (sLit "\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1935 hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket,
1937 hcat [ptext (sLit "\tst\t"), pprReg regH, pp_comma_lbracket,
1938 pprReg g1, ptext (sLit "+4]")],
1939 hcat [ptext (sLit "\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1944 -- st %f(n+1),[addr+4]
1945 pprInstr instr@(ST FF64 reg addr)
1946 = let Just addr2 = addrOffset addr 4
1947 Just regH = fPair reg
1949 hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket,
1950 pprAddr addr, rbrack],
1951 hcat [ptext (sLit "\tst\t"), pprReg regH, pp_comma_lbracket,
1952 pprAddr addr2, rbrack]
1957 -- no distinction is made between signed and unsigned bytes on stores for the
1958 -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
1959 -- so we call a special-purpose pprSize for ST..
1961 pprInstr (ST size reg addr)
1963 ptext (sLit "\tst"),
1972 pprInstr (ADD x cc reg1 ri reg2)
1973 | not x && not cc && riZero ri
1974 = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1977 = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2
1979 pprInstr (SUB x cc reg1 ri reg2)
1980 | not x && cc && reg2 == g0
1981 = hcat [ ptext (sLit "\tcmp\t"), pprReg reg1, comma, pprRI ri ]
1982 | not x && not cc && riZero ri
1983 = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1985 = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2
1987 pprInstr (AND b reg1 ri reg2) = pprRegRIReg (sLit "and") b reg1 ri reg2
1988 pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2
1990 pprInstr (OR b reg1 ri reg2)
1991 | not b && reg1 == g0
1992 = let doit = hcat [ ptext (sLit "\tmov\t"), pprRI ri, comma, pprReg reg2 ]
1994 RIReg rrr | rrr == reg2 -> empty
1998 = pprRegRIReg (sLit "or") b reg1 ri reg2
2000 pprInstr (ORN b reg1 ri reg2) = pprRegRIReg (sLit "orn") b reg1 ri reg2
2002 pprInstr (XOR b reg1 ri reg2) = pprRegRIReg (sLit "xor") b reg1 ri reg2
2003 pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg (sLit "xnor") b reg1 ri reg2
2005 pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") False reg1 ri reg2
2006 pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") False reg1 ri reg2
2007 pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") False reg1 ri reg2
2009 pprInstr (RDY rd) = ptext (sLit "\trd\t%y,") <> pprReg rd
2010 pprInstr (WRY reg1 reg2)
2011 = ptext (sLit "\twr\t")
2016 <> ptext (sLit "%y")
2018 pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul") b reg1 ri reg2
2019 pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul") b reg1 ri reg2
2020 pprInstr (SDIV b reg1 ri reg2) = pprRegRIReg (sLit "sdiv") b reg1 ri reg2
2021 pprInstr (UDIV b reg1 ri reg2) = pprRegRIReg (sLit "udiv") b reg1 ri reg2
2023 pprInstr (SETHI imm reg)
2025 ptext (sLit "\tsethi\t"),
2031 pprInstr NOP = ptext (sLit "\tnop")
2033 pprInstr (FABS FF32 reg1 reg2) = pprSizeRegReg (sLit "fabs") FF32 reg1 reg2
2034 pprInstr (FABS FF64 reg1 reg2)
2035 = let Just reg1H = fPair reg1
2036 Just reg2H = fPair reg2
2038 (<>) (pprSizeRegReg (sLit "fabs") FF32 reg1 reg2)
2039 (if (reg1 == reg2) then empty
2040 else (<>) (char '\n')
2041 (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
2043 pprInstr (FADD size reg1 reg2 reg3)
2044 = pprSizeRegRegReg (sLit "fadd") size reg1 reg2 reg3
2045 pprInstr (FCMP e size reg1 reg2)
2046 = pprSizeRegReg (if e then sLit "fcmpe" else sLit "fcmp") size reg1 reg2
2047 pprInstr (FDIV size reg1 reg2 reg3)
2048 = pprSizeRegRegReg (sLit "fdiv") size reg1 reg2 reg3
2050 pprInstr (FMOV FF32 reg1 reg2) = pprSizeRegReg (sLit "fmov") FF32 reg1 reg2
2051 pprInstr (FMOV FF64 reg1 reg2) = pprSizeRegReg (sLit "fmov") FF64 reg1 reg2
2054 pprInstr (FMOV FF64 reg1 reg2)
2055 = let Just reg1H = fPair reg1
2056 Just reg2H = fPair reg2
2058 (<>) (pprSizeRegReg (sLit "fmov") FF32 reg1 reg2)
2059 (if (reg1 == reg2) then empty
2060 else (<>) (char '\n')
2061 (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
2064 pprInstr (FMUL size reg1 reg2 reg3)
2065 = pprSizeRegRegReg (sLit "fmul") size reg1 reg2 reg3
2067 pprInstr (FNEG FF32 reg1 reg2) = pprSizeRegReg (sLit "fneg") FF32 reg1 reg2
2068 pprInstr (FNEG FF64 reg1 reg2)
2069 = let Just reg1H = fPair reg1
2070 Just reg2H = fPair reg2
2072 (<>) (pprSizeRegReg (sLit "fneg") FF32 reg1 reg2)
2073 (if (reg1 == reg2) then empty
2074 else (<>) (char '\n')
2075 (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
2077 pprInstr (FSQRT size reg1 reg2) = pprSizeRegReg (sLit "fsqrt") size reg1 reg2
2078 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fsub") size reg1 reg2 reg3
2079 pprInstr (FxTOy size1 size2 reg1 reg2)
2086 FF64 -> sLit "dto"),
2092 FF64 -> sLit "d\t"),
2093 pprReg reg1, comma, pprReg reg2
2097 pprInstr (BI cond b (BlockId id))
2099 ptext (sLit "\tb"), pprCond cond,
2100 if b then pp_comma_a else empty,
2102 pprCLabel_asm (mkAsmTempLabel id)
2105 pprInstr (BF cond b (BlockId id))
2107 ptext (sLit "\tfb"), pprCond cond,
2108 if b then pp_comma_a else empty,
2110 pprCLabel_asm (mkAsmTempLabel id)
2113 pprInstr (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr addr)
2114 pprInstr (JMP_TBL op ids) = pprInstr (JMP op)
2116 pprInstr (CALL (Left imm) n _)
2117 = hcat [ ptext (sLit "\tcall\t"), pprImm imm, comma, int n ]
2118 pprInstr (CALL (Right reg) n _)
2119 = hcat [ ptext (sLit "\tcall\t"), pprReg reg, comma, int n ]
2122 pprRI (RIReg r) = pprReg r
2123 pprRI (RIImm r) = pprImm r
2125 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
2126 pprSizeRegReg name size reg1 reg2
2131 FF32 -> ptext (sLit "s\t")
2132 FF64 -> ptext (sLit "d\t")),
2138 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
2139 pprSizeRegRegReg name size reg1 reg2 reg3
2144 FF32 -> ptext (sLit "s\t")
2145 FF64 -> ptext (sLit "d\t")),
2153 pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
2154 pprRegRIReg name b reg1 ri reg2
2158 if b then ptext (sLit "cc\t") else char '\t',
2166 pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
2167 pprRIReg name b ri reg1
2171 if b then ptext (sLit "cc\t") else char '\t',
2177 pp_ld_lbracket = ptext (sLit "\tld\t[")
2178 pp_rbracket_comma = text "],"
2179 pp_comma_lbracket = text ",["
2180 pp_comma_a = text ",a"
2182 #endif /* sparc_TARGET_ARCH */
2185 -- -----------------------------------------------------------------------------
2186 -- pprInstr for PowerPC
2188 #if powerpc_TARGET_ARCH
2190 pprInstr (SPILL reg slot)
2192 ptext (sLit "\tSPILL"),
2196 ptext (sLit "SLOT") <> parens (int slot)]
2198 pprInstr (RELOAD slot reg)
2200 ptext (sLit "\tRELOAD"),
2202 ptext (sLit "SLOT") <> parens (int slot),
2206 pprInstr (LD sz reg addr) = hcat [
2215 case addr of AddrRegImm _ _ -> empty
2216 AddrRegReg _ _ -> char 'x',
2222 pprInstr (LA sz reg addr) = hcat [
2231 case addr of AddrRegImm _ _ -> empty
2232 AddrRegReg _ _ -> char 'x',
2238 pprInstr (ST sz reg addr) = hcat [
2242 case addr of AddrRegImm _ _ -> empty
2243 AddrRegReg _ _ -> char 'x',
2249 pprInstr (STU sz reg addr) = hcat [
2254 case addr of AddrRegImm _ _ -> empty
2255 AddrRegReg _ _ -> char 'x',
2260 pprInstr (LIS reg imm) = hcat [
2268 pprInstr (LI reg imm) = hcat [
2276 pprInstr (MR reg1 reg2)
2277 | reg1 == reg2 = empty
2278 | otherwise = hcat [
2280 case regClass reg1 of
2281 RcInteger -> ptext (sLit "mr")
2282 _ -> ptext (sLit "fmr"),
2288 pprInstr (CMP sz reg ri) = hcat [
2304 pprInstr (CMPL sz reg ri) = hcat [
2314 ptext (sLit "cmpl"),
2320 pprInstr (BCC cond (BlockId id)) = hcat [
2327 where lbl = mkAsmTempLabel id
2329 pprInstr (BCCFAR cond (BlockId id)) = vcat [
2332 pprCond (condNegate cond),
2333 ptext (sLit "\t$+8")
2336 ptext (sLit "\tb\t"),
2340 where lbl = mkAsmTempLabel id
2342 pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
2349 pprInstr (MTCTR reg) = hcat [
2351 ptext (sLit "mtctr"),
2355 pprInstr (BCTR _) = hcat [
2359 pprInstr (BL lbl _) = hcat [
2360 ptext (sLit "\tbl\t"),
2363 pprInstr (BCTRL _) = hcat [
2365 ptext (sLit "bctrl")
2367 pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri
2368 pprInstr (ADDIS reg1 reg2 imm) = hcat [
2370 ptext (sLit "addis"),
2379 pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3)
2380 pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3)
2381 pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3)
2382 pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri
2383 pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri
2384 pprInstr (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3)
2385 pprInstr (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3)
2387 pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
2388 hcat [ ptext (sLit "\tmullwo\t"), pprReg reg1, ptext (sLit ", "),
2389 pprReg reg2, ptext (sLit ", "),
2391 hcat [ ptext (sLit "\tmfxer\t"), pprReg reg1 ],
2392 hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "),
2393 pprReg reg1, ptext (sLit ", "),
2394 ptext (sLit "2, 31, 31") ]
2397 -- for some reason, "andi" doesn't exist.
2398 -- we'll use "andi." instead.
2399 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
2401 ptext (sLit "andi."),
2409 pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri
2411 pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri
2412 pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri
2414 pprInstr (XORIS reg1 reg2 imm) = hcat [
2416 ptext (sLit "xoris"),
2425 pprInstr (EXTS sz reg1 reg2) = hcat [
2427 ptext (sLit "exts"),
2435 pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2
2436 pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2
2438 pprInstr (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri)
2439 pprInstr (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri)
2440 pprInstr (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri)
2441 pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
2442 ptext (sLit "\trlwinm\t"),
2454 pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF (sLit "fadd") sz reg1 reg2 reg3
2455 pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF (sLit "fsub") sz reg1 reg2 reg3
2456 pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF (sLit "fmul") sz reg1 reg2 reg3
2457 pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") sz reg1 reg2 reg3
2458 pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2
2460 pprInstr (FCMP reg1 reg2) = hcat [
2462 ptext (sLit "fcmpu\tcr0, "),
2463 -- Note: we're using fcmpu, not fcmpo
2464 -- The difference is with fcmpo, compare with NaN is an invalid operation.
2465 -- We don't handle invalid fp ops, so we don't care
2471 pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2
2472 pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2
2474 pprInstr (CRNOR dst src1 src2) = hcat [
2475 ptext (sLit "\tcrnor\t"),
2483 pprInstr (MFCR reg) = hcat [
2485 ptext (sLit "mfcr"),
2490 pprInstr (MFLR reg) = hcat [
2492 ptext (sLit "mflr"),
2497 pprInstr (FETCHPC reg) = vcat [
2498 ptext (sLit "\tbcl\t20,31,1f"),
2499 hcat [ ptext (sLit "1:\tmflr\t"), pprReg reg ]
2502 pprInstr LWSYNC = ptext (sLit "\tlwsync")
2504 pprInstr _ = panic "pprInstr (ppc)"
2506 pprLogic op reg1 reg2 ri = hcat [
2511 RIImm _ -> char 'i',
2520 pprUnary op reg1 reg2 = hcat [
2529 pprBinaryF op sz reg1 reg2 reg3 = hcat [
2542 pprRI (RIReg r) = pprReg r
2543 pprRI (RIImm r) = pprImm r
2545 pprFSize FF64 = empty
2546 pprFSize FF32 = char 's'
2548 -- limit immediate argument for shift instruction to range 0..32
2549 -- (yes, the maximum is really 32, not 31)
2550 limitShiftRI :: RI -> RI
2551 limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32)
2554 #endif /* powerpc_TARGET_ARCH */
2557 -- -----------------------------------------------------------------------------
2558 -- Converting floating-point literals to integrals for printing
2560 castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)
2561 castFloatToWord8Array = castSTUArray
2563 castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8)
2564 castDoubleToWord8Array = castSTUArray
2566 -- floatToBytes and doubleToBytes convert to the host's byte
2567 -- order. Providing that we're not cross-compiling for a
2568 -- target with the opposite endianness, this should work ok
2571 -- ToDo: this stuff is very similar to the shenanigans in PprAbs,
2572 -- could they be merged?
2574 floatToBytes :: Float -> [Int]
2577 arr <- newArray_ ((0::Int),3)
2579 arr <- castFloatToWord8Array arr
2580 i0 <- readArray arr 0
2581 i1 <- readArray arr 1
2582 i2 <- readArray arr 2
2583 i3 <- readArray arr 3
2584 return (map fromIntegral [i0,i1,i2,i3])
2587 doubleToBytes :: Double -> [Int]
2590 arr <- newArray_ ((0::Int),7)
2592 arr <- castDoubleToWord8Array arr
2593 i0 <- readArray arr 0
2594 i1 <- readArray arr 1
2595 i2 <- readArray arr 2
2596 i3 <- readArray arr 3
2597 i4 <- readArray arr 4
2598 i5 <- readArray arr 5
2599 i6 <- readArray arr 6
2600 i7 <- readArray arr 7
2601 return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7])