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 MachRegs -- may differ per-platform
34 import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel,
35 labelDynamic, mkAsmTempLabel, entryLblToInfoLbl )
36 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
37 import CLabel ( mkDeadStripPreventer )
40 import Panic ( panic )
41 import Unique ( pprUnique )
44 import qualified Outputable
45 import Outputable ( Outputable, pprPanic, ppr, docToSDoc)
48 import Data.Word ( Word8 )
49 import Control.Monad.ST
50 import Data.Char ( chr, ord )
51 import Data.Maybe ( isJust )
53 #if powerpc_TARGET_ARCH || darwin_TARGET_OS
54 import Data.Word(Word32)
58 -- -----------------------------------------------------------------------------
59 -- Printing this stuff out
61 asmSDoc d = Outputable.withPprStyleDoc (
62 Outputable.mkCodeStyle Outputable.AsmStyle) d
63 pprCLabel_asm l = asmSDoc (pprCLabel l)
65 pprNatCmmTop :: NatCmmTop -> Doc
66 pprNatCmmTop (CmmData section dats) =
67 pprSectionHeader section $$ vcat (map pprData dats)
69 -- special case for split markers:
70 pprNatCmmTop (CmmProc [] lbl _ (ListGraph [])) = pprLabel lbl
72 pprNatCmmTop (CmmProc info lbl params (ListGraph blocks)) =
73 pprSectionHeader Text $$
74 (if null info then -- blocks guaranteed not null, so label needed
77 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
78 pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
81 vcat (map pprData info) $$
82 pprLabel (entryLblToInfoLbl lbl)
84 vcat (map pprBasicBlock blocks)
85 -- above: Even the first block gets a label, because with branch-chain
86 -- elimination, it might be the target of a goto.
87 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
88 -- If we are using the .subsections_via_symbols directive
89 -- (available on recent versions of Darwin),
90 -- we have to make sure that there is some kind of reference
91 -- from the entry code to a label on the _top_ of of the info table,
92 -- so that the linker will not think it is unreferenced and dead-strip
93 -- it. That's why the label is called a DeadStripPreventer (_dsp).
96 <+> pprCLabel_asm (entryLblToInfoLbl lbl)
98 <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
103 pprBasicBlock :: NatBasicBlock -> Doc
104 pprBasicBlock (BasicBlock (BlockId id) instrs) =
105 pprLabel (mkAsmTempLabel id) $$
106 vcat (map pprInstr instrs)
108 -- -----------------------------------------------------------------------------
109 -- pprReg: print a 'Reg'
111 -- For x86, the way we print a register name depends
112 -- on which bit of it we care about. Yurgh.
114 pprUserReg :: Reg -> Doc
115 pprUserReg = pprReg IF_ARCH_i386(II32,) IF_ARCH_x86_64(II64,)
117 pprReg :: IF_ARCH_i386(Size ->,) IF_ARCH_x86_64(Size ->,) Reg -> Doc
119 pprReg IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) r
121 RealReg i -> ppr_reg_no IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) i
122 VirtualRegI u -> text "%vI_" <> asmSDoc (pprUnique u)
123 VirtualRegHi u -> text "%vHi_" <> asmSDoc (pprUnique u)
124 VirtualRegF u -> text "%vF_" <> asmSDoc (pprUnique u)
125 VirtualRegD u -> text "%vD_" <> asmSDoc (pprUnique u)
127 #if alpha_TARGET_ARCH
128 ppr_reg_no :: Int -> Doc
131 0 -> sLit "$0"; 1 -> sLit "$1";
132 2 -> sLit "$2"; 3 -> sLit "$3";
133 4 -> sLit "$4"; 5 -> sLit "$5";
134 6 -> sLit "$6"; 7 -> sLit "$7";
135 8 -> sLit "$8"; 9 -> sLit "$9";
136 10 -> sLit "$10"; 11 -> sLit "$11";
137 12 -> sLit "$12"; 13 -> sLit "$13";
138 14 -> sLit "$14"; 15 -> sLit "$15";
139 16 -> sLit "$16"; 17 -> sLit "$17";
140 18 -> sLit "$18"; 19 -> sLit "$19";
141 20 -> sLit "$20"; 21 -> sLit "$21";
142 22 -> sLit "$22"; 23 -> sLit "$23";
143 24 -> sLit "$24"; 25 -> sLit "$25";
144 26 -> sLit "$26"; 27 -> sLit "$27";
145 28 -> sLit "$28"; 29 -> sLit "$29";
146 30 -> sLit "$30"; 31 -> sLit "$31";
147 32 -> sLit "$f0"; 33 -> sLit "$f1";
148 34 -> sLit "$f2"; 35 -> sLit "$f3";
149 36 -> sLit "$f4"; 37 -> sLit "$f5";
150 38 -> sLit "$f6"; 39 -> sLit "$f7";
151 40 -> sLit "$f8"; 41 -> sLit "$f9";
152 42 -> sLit "$f10"; 43 -> sLit "$f11";
153 44 -> sLit "$f12"; 45 -> sLit "$f13";
154 46 -> sLit "$f14"; 47 -> sLit "$f15";
155 48 -> sLit "$f16"; 49 -> sLit "$f17";
156 50 -> sLit "$f18"; 51 -> sLit "$f19";
157 52 -> sLit "$f20"; 53 -> sLit "$f21";
158 54 -> sLit "$f22"; 55 -> sLit "$f23";
159 56 -> sLit "$f24"; 57 -> sLit "$f25";
160 58 -> sLit "$f26"; 59 -> sLit "$f27";
161 60 -> sLit "$f28"; 61 -> sLit "$f29";
162 62 -> sLit "$f30"; 63 -> sLit "$f31";
163 _ -> sLit "very naughty alpha register"
167 ppr_reg_no :: Size -> Int -> Doc
168 ppr_reg_no II8 = ppr_reg_byte
169 ppr_reg_no II16 = ppr_reg_word
170 ppr_reg_no _ = ppr_reg_long
172 ppr_reg_byte i = ptext
174 0 -> sLit "%al"; 1 -> sLit "%bl";
175 2 -> sLit "%cl"; 3 -> sLit "%dl";
176 _ -> sLit "very naughty I386 byte register"
179 ppr_reg_word i = ptext
181 0 -> sLit "%ax"; 1 -> sLit "%bx";
182 2 -> sLit "%cx"; 3 -> sLit "%dx";
183 4 -> sLit "%si"; 5 -> sLit "%di";
184 6 -> sLit "%bp"; 7 -> sLit "%sp";
185 _ -> sLit "very naughty I386 word register"
188 ppr_reg_long i = ptext
190 0 -> sLit "%eax"; 1 -> sLit "%ebx";
191 2 -> sLit "%ecx"; 3 -> sLit "%edx";
192 4 -> sLit "%esi"; 5 -> sLit "%edi";
193 6 -> sLit "%ebp"; 7 -> sLit "%esp";
194 8 -> sLit "%fake0"; 9 -> sLit "%fake1";
195 10 -> sLit "%fake2"; 11 -> sLit "%fake3";
196 12 -> sLit "%fake4"; 13 -> sLit "%fake5";
197 _ -> sLit "very naughty I386 register"
201 #if x86_64_TARGET_ARCH
202 ppr_reg_no :: Size -> Int -> Doc
203 ppr_reg_no II8 = ppr_reg_byte
204 ppr_reg_no II16 = ppr_reg_word
205 ppr_reg_no II32 = ppr_reg_long
206 ppr_reg_no _ = ppr_reg_quad
208 ppr_reg_byte i = ptext
210 0 -> sLit "%al"; 1 -> sLit "%bl";
211 2 -> sLit "%cl"; 3 -> sLit "%dl";
212 4 -> sLit "%sil"; 5 -> sLit "%dil"; -- new 8-bit regs!
213 6 -> sLit "%bpl"; 7 -> sLit "%spl";
214 8 -> sLit "%r8b"; 9 -> sLit "%r9b";
215 10 -> sLit "%r10b"; 11 -> sLit "%r11b";
216 12 -> sLit "%r12b"; 13 -> sLit "%r13b";
217 14 -> sLit "%r14b"; 15 -> sLit "%r15b";
218 _ -> sLit "very naughty x86_64 byte register"
221 ppr_reg_word i = ptext
223 0 -> sLit "%ax"; 1 -> sLit "%bx";
224 2 -> sLit "%cx"; 3 -> sLit "%dx";
225 4 -> sLit "%si"; 5 -> sLit "%di";
226 6 -> sLit "%bp"; 7 -> sLit "%sp";
227 8 -> sLit "%r8w"; 9 -> sLit "%r9w";
228 10 -> sLit "%r10w"; 11 -> sLit "%r11w";
229 12 -> sLit "%r12w"; 13 -> sLit "%r13w";
230 14 -> sLit "%r14w"; 15 -> sLit "%r15w";
231 _ -> sLit "very naughty x86_64 word register"
234 ppr_reg_long i = ptext
236 0 -> sLit "%eax"; 1 -> sLit "%ebx";
237 2 -> sLit "%ecx"; 3 -> sLit "%edx";
238 4 -> sLit "%esi"; 5 -> sLit "%edi";
239 6 -> sLit "%ebp"; 7 -> sLit "%esp";
240 8 -> sLit "%r8d"; 9 -> sLit "%r9d";
241 10 -> sLit "%r10d"; 11 -> sLit "%r11d";
242 12 -> sLit "%r12d"; 13 -> sLit "%r13d";
243 14 -> sLit "%r14d"; 15 -> sLit "%r15d";
244 _ -> sLit "very naughty x86_64 register"
247 ppr_reg_quad i = ptext
249 0 -> sLit "%rax"; 1 -> sLit "%rbx";
250 2 -> sLit "%rcx"; 3 -> sLit "%rdx";
251 4 -> sLit "%rsi"; 5 -> sLit "%rdi";
252 6 -> sLit "%rbp"; 7 -> sLit "%rsp";
253 8 -> sLit "%r8"; 9 -> sLit "%r9";
254 10 -> sLit "%r10"; 11 -> sLit "%r11";
255 12 -> sLit "%r12"; 13 -> sLit "%r13";
256 14 -> sLit "%r14"; 15 -> sLit "%r15";
257 16 -> sLit "%xmm0"; 17 -> sLit "%xmm1";
258 18 -> sLit "%xmm2"; 19 -> sLit "%xmm3";
259 20 -> sLit "%xmm4"; 21 -> sLit "%xmm5";
260 22 -> sLit "%xmm6"; 23 -> sLit "%xmm7";
261 24 -> sLit "%xmm8"; 25 -> sLit "%xmm9";
262 26 -> sLit "%xmm10"; 27 -> sLit "%xmm11";
263 28 -> sLit "%xmm12"; 29 -> sLit "%xmm13";
264 30 -> sLit "%xmm14"; 31 -> sLit "%xmm15";
265 _ -> sLit "very naughty x86_64 register"
269 #if sparc_TARGET_ARCH
270 ppr_reg_no :: Int -> Doc
273 0 -> sLit "%g0"; 1 -> sLit "%g1";
274 2 -> sLit "%g2"; 3 -> sLit "%g3";
275 4 -> sLit "%g4"; 5 -> sLit "%g5";
276 6 -> sLit "%g6"; 7 -> sLit "%g7";
277 8 -> sLit "%o0"; 9 -> sLit "%o1";
278 10 -> sLit "%o2"; 11 -> sLit "%o3";
279 12 -> sLit "%o4"; 13 -> sLit "%o5";
280 14 -> sLit "%o6"; 15 -> sLit "%o7";
281 16 -> sLit "%l0"; 17 -> sLit "%l1";
282 18 -> sLit "%l2"; 19 -> sLit "%l3";
283 20 -> sLit "%l4"; 21 -> sLit "%l5";
284 22 -> sLit "%l6"; 23 -> sLit "%l7";
285 24 -> sLit "%i0"; 25 -> sLit "%i1";
286 26 -> sLit "%i2"; 27 -> sLit "%i3";
287 28 -> sLit "%i4"; 29 -> sLit "%i5";
288 30 -> sLit "%i6"; 31 -> sLit "%i7";
289 32 -> sLit "%f0"; 33 -> sLit "%f1";
290 34 -> sLit "%f2"; 35 -> sLit "%f3";
291 36 -> sLit "%f4"; 37 -> sLit "%f5";
292 38 -> sLit "%f6"; 39 -> sLit "%f7";
293 40 -> sLit "%f8"; 41 -> sLit "%f9";
294 42 -> sLit "%f10"; 43 -> sLit "%f11";
295 44 -> sLit "%f12"; 45 -> sLit "%f13";
296 46 -> sLit "%f14"; 47 -> sLit "%f15";
297 48 -> sLit "%f16"; 49 -> sLit "%f17";
298 50 -> sLit "%f18"; 51 -> sLit "%f19";
299 52 -> sLit "%f20"; 53 -> sLit "%f21";
300 54 -> sLit "%f22"; 55 -> sLit "%f23";
301 56 -> sLit "%f24"; 57 -> sLit "%f25";
302 58 -> sLit "%f26"; 59 -> sLit "%f27";
303 60 -> sLit "%f28"; 61 -> sLit "%f29";
304 62 -> sLit "%f30"; 63 -> sLit "%f31";
305 _ -> sLit "very naughty sparc register"
308 #if powerpc_TARGET_ARCH
310 ppr_reg_no :: Int -> Doc
313 0 -> sLit "r0"; 1 -> sLit "r1";
314 2 -> sLit "r2"; 3 -> sLit "r3";
315 4 -> sLit "r4"; 5 -> sLit "r5";
316 6 -> sLit "r6"; 7 -> sLit "r7";
317 8 -> sLit "r8"; 9 -> sLit "r9";
318 10 -> sLit "r10"; 11 -> sLit "r11";
319 12 -> sLit "r12"; 13 -> sLit "r13";
320 14 -> sLit "r14"; 15 -> sLit "r15";
321 16 -> sLit "r16"; 17 -> sLit "r17";
322 18 -> sLit "r18"; 19 -> sLit "r19";
323 20 -> sLit "r20"; 21 -> sLit "r21";
324 22 -> sLit "r22"; 23 -> sLit "r23";
325 24 -> sLit "r24"; 25 -> sLit "r25";
326 26 -> sLit "r26"; 27 -> sLit "r27";
327 28 -> sLit "r28"; 29 -> sLit "r29";
328 30 -> sLit "r30"; 31 -> sLit "r31";
329 32 -> sLit "f0"; 33 -> sLit "f1";
330 34 -> sLit "f2"; 35 -> sLit "f3";
331 36 -> sLit "f4"; 37 -> sLit "f5";
332 38 -> sLit "f6"; 39 -> sLit "f7";
333 40 -> sLit "f8"; 41 -> sLit "f9";
334 42 -> sLit "f10"; 43 -> sLit "f11";
335 44 -> sLit "f12"; 45 -> sLit "f13";
336 46 -> sLit "f14"; 47 -> sLit "f15";
337 48 -> sLit "f16"; 49 -> sLit "f17";
338 50 -> sLit "f18"; 51 -> sLit "f19";
339 52 -> sLit "f20"; 53 -> sLit "f21";
340 54 -> sLit "f22"; 55 -> sLit "f23";
341 56 -> sLit "f24"; 57 -> sLit "f25";
342 58 -> sLit "f26"; 59 -> sLit "f27";
343 60 -> sLit "f28"; 61 -> sLit "f29";
344 62 -> sLit "f30"; 63 -> sLit "f31";
345 _ -> sLit "very naughty powerpc register"
348 ppr_reg_no :: Int -> Doc
349 ppr_reg_no i | i <= 31 = int i -- GPRs
350 | i <= 63 = int (i-32) -- FPRs
351 | otherwise = ptext (sLit "very naughty powerpc register")
356 -- -----------------------------------------------------------------------------
358 -- Used for instruction suffixes.
359 -- eg LD is 32bit on sparc, but LDD is 64 bit.
362 #if powerpc_TARGET_ARCH || i386_TARGET_ARCH || x86_64_TARGET_ARCH || sparc_TARGET_ARCH
363 pprSize :: Size -> Doc
365 pprSize :: Size -> Doc
368 pprSize x = ptext (case x of
369 #if alpha_TARGET_ARCH
372 -- W -> sLit "w" UNUSED
373 -- Wu -> sLit "wu" UNUSED
376 -- FF -> sLit "f" UNUSED
377 -- DF -> sLit "d" UNUSED
378 -- GF -> sLit "g" UNUSED
379 -- SF -> sLit "s" UNUSED
382 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
393 #if x86_64_TARGET_ARCH
394 FF32 -> sLit "ss" -- "scalar single-precision float" (SSE2)
395 FF64 -> sLit "sd" -- "scalar double-precision float" (SSE2)
397 #if sparc_TARGET_ARCH
406 -- suffix to store/ ST instruction
407 pprStSize :: Size -> Doc
408 pprStSize x = ptext (case x of
416 #if powerpc_TARGET_ARCH
425 -- -----------------------------------------------------------------------------
426 -- pprCond: print a 'Cond'
428 pprCond :: Cond -> Doc
430 pprCond c = ptext (case c of {
431 #if alpha_TARGET_ARCH
441 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
442 GEU -> sLit "ae"; LU -> sLit "b";
443 EQQ -> sLit "e"; GTT -> sLit "g";
444 GE -> sLit "ge"; GU -> sLit "a";
445 LTT -> sLit "l"; LE -> sLit "le";
446 LEU -> sLit "be"; NE -> sLit "ne";
447 NEG -> sLit "s"; POS -> sLit "ns";
448 CARRY -> sLit "c"; OFLO -> sLit "o";
449 PARITY -> sLit "p"; NOTPARITY -> sLit "np";
450 ALWAYS -> sLit "mp" -- hack
452 #if sparc_TARGET_ARCH
453 ALWAYS -> sLit ""; NEVER -> sLit "n";
454 GEU -> sLit "geu"; LU -> sLit "lu";
455 EQQ -> sLit "e"; GTT -> sLit "g";
456 GE -> sLit "ge"; GU -> sLit "gu";
457 LTT -> sLit "l"; LE -> sLit "le";
458 LEU -> sLit "leu"; NE -> sLit "ne";
459 NEG -> sLit "neg"; POS -> sLit "pos";
460 VC -> sLit "vc"; VS -> sLit "vs"
462 #if powerpc_TARGET_ARCH
464 EQQ -> sLit "eq"; NE -> sLit "ne";
465 LTT -> sLit "lt"; GE -> sLit "ge";
466 GTT -> sLit "gt"; LE -> sLit "le";
467 LU -> sLit "lt"; GEU -> sLit "ge";
468 GU -> sLit "gt"; LEU -> sLit "le";
473 -- -----------------------------------------------------------------------------
474 -- pprImm: print an 'Imm'
478 pprImm (ImmInt i) = int i
479 pprImm (ImmInteger i) = integer i
480 pprImm (ImmCLbl l) = pprCLabel_asm l
481 pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i
482 pprImm (ImmLit s) = s
484 pprImm (ImmFloat _) = ptext (sLit "naughty float immediate")
485 pprImm (ImmDouble _) = ptext (sLit "naughty double immediate")
487 pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
488 -- #if sparc_TARGET_ARCH
489 -- ToDo: This should really be fixed in the PIC support, but only
491 -- pprImm (ImmConstantDiff a b) = pprImm a
493 pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
494 <> lparen <> pprImm b <> rparen
497 #if sparc_TARGET_ARCH
499 = hcat [ pp_lo, pprImm i, rparen ]
504 = hcat [ pp_hi, pprImm i, rparen ]
508 #if powerpc_TARGET_ARCH
511 = hcat [ pp_lo, pprImm i, rparen ]
516 = hcat [ pp_hi, pprImm i, rparen ]
521 = hcat [ pp_ha, pprImm i, rparen ]
527 = pprImm i <> text "@l"
530 = pprImm i <> text "@h"
533 = pprImm i <> text "@ha"
538 -- -----------------------------------------------------------------------------
539 -- @pprAddr: print an 'AddrMode'
541 pprAddr :: AddrMode -> Doc
543 #if alpha_TARGET_ARCH
544 pprAddr (AddrReg r) = parens (pprReg r)
545 pprAddr (AddrImm i) = pprImm i
546 pprAddr (AddrRegImm r1 i)
547 = (<>) (pprImm i) (parens (pprReg r1))
552 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
553 pprAddr (ImmAddr imm off)
554 = let pp_imm = pprImm imm
558 else if (off < 0) then
561 pp_imm <> char '+' <> int off
563 pprAddr (AddrBaseIndex base index displacement)
565 pp_disp = ppr_disp displacement
566 pp_off p = pp_disp <> char '(' <> p <> char ')'
567 pp_reg r = pprReg wordSize r
570 (EABaseNone, EAIndexNone) -> pp_disp
571 (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b)
572 (EABaseRip, EAIndexNone) -> pp_off (ptext (sLit "%rip"))
573 (EABaseNone, EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i)
574 (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r
577 ppr_disp (ImmInt 0) = empty
578 ppr_disp imm = pprImm imm
583 #if sparc_TARGET_ARCH
584 pprAddr (AddrRegReg r1 (RealReg 0)) = pprReg r1
586 pprAddr (AddrRegReg r1 r2)
587 = hcat [ pprReg r1, char '+', pprReg r2 ]
589 pprAddr (AddrRegImm r1 (ImmInt i))
591 | not (fits13Bits i) = largeOffsetError i
592 | otherwise = hcat [ pprReg r1, pp_sign, int i ]
594 pp_sign = if i > 0 then char '+' else empty
596 pprAddr (AddrRegImm r1 (ImmInteger i))
598 | not (fits13Bits i) = largeOffsetError i
599 | otherwise = hcat [ pprReg r1, pp_sign, integer i ]
601 pp_sign = if i > 0 then char '+' else empty
603 pprAddr (AddrRegImm r1 imm)
604 = hcat [ pprReg r1, char '+', pprImm imm ]
609 #if powerpc_TARGET_ARCH
610 pprAddr (AddrRegReg r1 r2)
611 = pprReg r1 <+> ptext (sLit ", ") <+> pprReg r2
613 pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ]
614 pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ]
615 pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]
619 -- -----------------------------------------------------------------------------
620 -- pprData: print a 'CmmStatic'
622 pprSectionHeader Text
624 (IF_ARCH_alpha(sLit "\t.text\n\t.align 3" {-word boundary-}
625 ,IF_ARCH_sparc(sLit ".text\n\t.align 4" {-word boundary-}
626 ,IF_ARCH_i386(IF_OS_darwin(sLit ".text\n\t.align 2",
627 sLit ".text\n\t.align 4,0x90")
628 {-needs per-OS variation!-}
629 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".text\n.align 3",
630 sLit ".text\n\t.align 8")
631 ,IF_ARCH_powerpc(sLit ".text\n.align 2"
633 pprSectionHeader Data
635 (IF_ARCH_alpha(sLit "\t.data\n\t.align 3"
636 ,IF_ARCH_sparc(sLit ".data\n\t.align 8" {-<8 will break double constants -}
637 ,IF_ARCH_i386(IF_OS_darwin(sLit ".data\n\t.align 2",
638 sLit ".data\n\t.align 4")
639 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".data\n.align 3",
640 sLit ".data\n\t.align 8")
641 ,IF_ARCH_powerpc(sLit ".data\n.align 2"
643 pprSectionHeader ReadOnlyData
645 (IF_ARCH_alpha(sLit "\t.data\n\t.align 3"
646 ,IF_ARCH_sparc(sLit ".text\n\t.align 8" {-<8 will break double constants -}
647 ,IF_ARCH_i386(IF_OS_darwin(sLit ".const\n.align 2",
648 sLit ".section .rodata\n\t.align 4")
649 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".const\n.align 3",
650 sLit ".section .rodata\n\t.align 8")
651 ,IF_ARCH_powerpc(IF_OS_darwin(sLit ".const\n.align 2",
652 sLit ".section .rodata\n\t.align 2")
654 pprSectionHeader RelocatableReadOnlyData
656 (IF_ARCH_alpha(sLit "\t.data\n\t.align 3"
657 ,IF_ARCH_sparc(sLit ".text\n\t.align 8" {-<8 will break double constants -}
658 ,IF_ARCH_i386(IF_OS_darwin(sLit ".const_data\n.align 2",
659 sLit ".section .data\n\t.align 4")
660 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".const_data\n.align 3",
661 sLit ".section .data\n\t.align 8")
662 ,IF_ARCH_powerpc(IF_OS_darwin(sLit ".const_data\n.align 2",
663 sLit ".data\n\t.align 2")
665 pprSectionHeader UninitialisedData
667 (IF_ARCH_alpha(sLit "\t.bss\n\t.align 3"
668 ,IF_ARCH_sparc(sLit ".bss\n\t.align 8" {-<8 will break double constants -}
669 ,IF_ARCH_i386(IF_OS_darwin(sLit ".data\n\t.align 2",
670 sLit ".section .bss\n\t.align 4")
671 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".data\n\t.align 3",
672 sLit ".section .bss\n\t.align 8")
673 ,IF_ARCH_powerpc(IF_OS_darwin(sLit ".const_data\n.align 2",
674 sLit ".section .bss\n\t.align 2")
676 pprSectionHeader ReadOnlyData16
678 (IF_ARCH_alpha(sLit "\t.data\n\t.align 4"
679 ,IF_ARCH_sparc(sLit ".data\n\t.align 16"
680 ,IF_ARCH_i386(IF_OS_darwin(sLit ".const\n.align 4",
681 sLit ".section .rodata\n\t.align 16")
682 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".const\n.align 4",
683 sLit ".section .rodata.cst16\n\t.align 16")
684 ,IF_ARCH_powerpc(IF_OS_darwin(sLit ".const\n.align 4",
685 sLit ".section .rodata\n\t.align 4")
688 pprSectionHeader (OtherSection sec)
689 = panic "PprMach.pprSectionHeader: unknown section"
691 pprData :: CmmStatic -> Doc
692 pprData (CmmAlign bytes) = pprAlign bytes
693 pprData (CmmDataLabel lbl) = pprLabel lbl
694 pprData (CmmString str) = pprASCII str
695 pprData (CmmUninitialised bytes) = ptext (sLit ".space ") <> int bytes
696 pprData (CmmStaticLit lit) = pprDataItem lit
698 pprGloblDecl :: CLabel -> Doc
700 | not (externallyVisibleCLabel lbl) = empty
701 | otherwise = ptext IF_ARCH_sparc((sLit ".global "),
705 pprTypeAndSizeDecl :: CLabel -> Doc
706 pprTypeAndSizeDecl lbl
708 | not (externallyVisibleCLabel lbl) = empty
709 | otherwise = ptext (sLit ".type ") <>
710 pprCLabel_asm lbl <> ptext (sLit ", @object")
715 pprLabel :: CLabel -> Doc
716 pprLabel lbl = pprGloblDecl lbl $$ pprTypeAndSizeDecl lbl $$ (pprCLabel_asm lbl <> char ':')
720 = vcat (map do1 str) $$ do1 0
723 do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w)
726 IF_ARCH_alpha(ptext (sLit ".align ") <> int pow2,
727 IF_ARCH_i386(ptext (sLit ".align ") <> int IF_OS_darwin(pow2,bytes),
728 IF_ARCH_x86_64(ptext (sLit ".align ") <> int IF_OS_darwin(pow2,bytes),
729 IF_ARCH_sparc(ptext (sLit ".align ") <> int bytes,
730 IF_ARCH_powerpc(ptext (sLit ".align ") <> int pow2,)))))
734 log2 :: Int -> Int -- cache the common ones
739 log2 n = 1 + log2 (n `quot` 2)
742 pprDataItem :: CmmLit -> Doc
744 = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit)
748 -- These seem to be common:
749 ppr_item II8 x = [ptext (sLit "\t.byte\t") <> pprImm imm]
750 ppr_item II32 x = [ptext (sLit "\t.long\t") <> pprImm imm]
751 ppr_item FF32 (CmmFloat r _)
752 = let bs = floatToBytes (fromRational r)
753 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
754 ppr_item FF64 (CmmFloat r _)
755 = let bs = doubleToBytes (fromRational r)
756 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
758 #if sparc_TARGET_ARCH
759 -- copy n paste of x86 version
760 ppr_item II16 x = [ptext (sLit "\t.short\t") <> pprImm imm]
761 ppr_item II64 x = [ptext (sLit "\t.quad\t") <> pprImm imm]
763 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
764 ppr_item II16 x = [ptext (sLit "\t.word\t") <> pprImm imm]
766 #if i386_TARGET_ARCH && darwin_TARGET_OS
767 ppr_item II64 (CmmInt x _) =
768 [ptext (sLit "\t.long\t")
769 <> int (fromIntegral (fromIntegral x :: Word32)),
770 ptext (sLit "\t.long\t")
772 (fromIntegral (x `shiftR` 32) :: Word32))]
774 #if i386_TARGET_ARCH || (darwin_TARGET_OS && x86_64_TARGET_ARCH)
775 ppr_item II64 x = [ptext (sLit "\t.quad\t") <> pprImm imm]
777 #if x86_64_TARGET_ARCH && !darwin_TARGET_OS
778 -- x86_64: binutils can't handle the R_X86_64_PC64 relocation
779 -- type, which means we can't do pc-relative 64-bit addresses.
780 -- Fortunately we're assuming the small memory model, in which
781 -- all such offsets will fit into 32 bits, so we have to stick
782 -- to 32-bit offset fields and modify the RTS appropriately
784 -- See Note [x86-64-relative] in includes/InfoTables.h
787 | isRelativeReloc x =
788 [ptext (sLit "\t.long\t") <> pprImm imm,
789 ptext (sLit "\t.long\t0")]
791 [ptext (sLit "\t.quad\t") <> pprImm imm]
793 isRelativeReloc (CmmLabelDiffOff _ _ _) = True
794 isRelativeReloc _ = False
796 #if powerpc_TARGET_ARCH
797 ppr_item II16 x = [ptext (sLit "\t.short\t") <> pprImm imm]
798 ppr_item II64 (CmmInt x _) =
799 [ptext (sLit "\t.long\t")
801 (fromIntegral (x `shiftR` 32) :: Word32)),
802 ptext (sLit "\t.long\t")
803 <> int (fromIntegral (fromIntegral x :: Word32))]
806 -- fall through to rest of (machine-specific) pprInstr...
808 -- -----------------------------------------------------------------------------
809 -- pprInstr: print an 'Instr'
811 instance Outputable Instr where
812 ppr instr = Outputable.docToSDoc $ pprInstr instr
814 pprInstr :: Instr -> Doc
816 pprInstr (COMMENT s) = empty -- nuke 'em
819 = IF_ARCH_alpha( ((<>) (ptext (sLit "\t# ")) (ftext s))
820 ,IF_ARCH_sparc( ((<>) (ptext (sLit "# ")) (ftext s))
821 ,IF_ARCH_i386( ((<>) (ptext (sLit "# ")) (ftext s))
822 ,IF_ARCH_x86_64( ((<>) (ptext (sLit "# ")) (ftext s))
823 ,IF_ARCH_powerpc( IF_OS_linux(
824 ((<>) (ptext (sLit "# ")) (ftext s)),
825 ((<>) (ptext (sLit "; ")) (ftext s)))
829 = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
831 pprInstr (NEWBLOCK _)
832 = panic "PprMach.pprInstr: NEWBLOCK"
835 = panic "PprMach.pprInstr: LDATA"
837 -- -----------------------------------------------------------------------------
838 -- pprInstr for an Alpha
840 #if alpha_TARGET_ARCH
842 pprInstr (SPILL reg slot)
844 ptext (sLit "\tSPILL"),
848 ptext (sLit "SLOT") <> parens (int slot)]
850 pprInstr (RELOAD slot reg)
852 ptext (sLit "\tRELOAD"),
854 ptext (sLit "SLOT") <> parens (int slot),
858 pprInstr (LD size reg addr)
868 pprInstr (LDA reg addr)
870 ptext (sLit "\tlda\t"),
876 pprInstr (LDAH reg addr)
878 ptext (sLit "\tldah\t"),
884 pprInstr (LDGP reg addr)
886 ptext (sLit "\tldgp\t"),
892 pprInstr (LDI size reg imm)
894 ptext (sLit "\tldi"),
902 pprInstr (ST size reg addr)
914 ptext (sLit "\tclr\t"),
918 pprInstr (ABS size ri reg)
920 ptext (sLit "\tabs"),
928 pprInstr (NEG size ov ri reg)
930 ptext (sLit "\tneg"),
932 if ov then ptext (sLit "v\t") else char '\t',
938 pprInstr (ADD size ov reg1 ri reg2)
940 ptext (sLit "\tadd"),
942 if ov then ptext (sLit "v\t") else char '\t',
950 pprInstr (SADD size scale reg1 ri reg2)
952 ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
963 pprInstr (SUB size ov reg1 ri reg2)
965 ptext (sLit "\tsub"),
967 if ov then ptext (sLit "v\t") else char '\t',
975 pprInstr (SSUB size scale reg1 ri reg2)
977 ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
988 pprInstr (MUL size ov reg1 ri reg2)
990 ptext (sLit "\tmul"),
992 if ov then ptext (sLit "v\t") else char '\t',
1000 pprInstr (DIV size uns reg1 ri reg2)
1002 ptext (sLit "\tdiv"),
1004 if uns then ptext (sLit "u\t") else char '\t',
1012 pprInstr (REM size uns reg1 ri reg2)
1014 ptext (sLit "\trem"),
1016 if uns then ptext (sLit "u\t") else char '\t',
1024 pprInstr (NOT ri reg)
1026 ptext (sLit "\tnot"),
1033 pprInstr (AND reg1 ri reg2) = pprRegRIReg (sLit "and") reg1 ri reg2
1034 pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg (sLit "andnot") reg1 ri reg2
1035 pprInstr (OR reg1 ri reg2) = pprRegRIReg (sLit "or") reg1 ri reg2
1036 pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg (sLit "ornot") reg1 ri reg2
1037 pprInstr (XOR reg1 ri reg2) = pprRegRIReg (sLit "xor") reg1 ri reg2
1038 pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg (sLit "xornot") reg1 ri reg2
1040 pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") reg1 ri reg2
1041 pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") reg1 ri reg2
1042 pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") reg1 ri reg2
1044 pprInstr (ZAP reg1 ri reg2) = pprRegRIReg (sLit "zap") reg1 ri reg2
1045 pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg (sLit "zapnot") reg1 ri reg2
1047 pprInstr (NOP) = ptext (sLit "\tnop")
1049 pprInstr (CMP cond reg1 ri reg2)
1051 ptext (sLit "\tcmp"),
1063 ptext (sLit "\tfclr\t"),
1067 pprInstr (FABS reg1 reg2)
1069 ptext (sLit "\tfabs\t"),
1075 pprInstr (FNEG size reg1 reg2)
1077 ptext (sLit "\tneg"),
1085 pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "add") size reg1 reg2 reg3
1086 pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "div") size reg1 reg2 reg3
1087 pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "mul") size reg1 reg2 reg3
1088 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "sub") size reg1 reg2 reg3
1090 pprInstr (CVTxy size1 size2 reg1 reg2)
1092 ptext (sLit "\tcvt"),
1094 case size2 of {Q -> ptext (sLit "qc"); _ -> pprSize size2},
1101 pprInstr (FCMP size cond reg1 reg2 reg3)
1103 ptext (sLit "\tcmp"),
1114 pprInstr (FMOV reg1 reg2)
1116 ptext (sLit "\tfmov\t"),
1122 pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
1124 pprInstr (BI NEVER reg lab) = empty
1126 pprInstr (BI cond reg lab)
1136 pprInstr (BF cond reg lab)
1138 ptext (sLit "\tfb"),
1147 = (<>) (ptext (sLit "\tbr\t")) (pprImm lab)
1149 pprInstr (JMP reg addr hint)
1151 ptext (sLit "\tjmp\t"),
1159 pprInstr (BSR imm n)
1160 = (<>) (ptext (sLit "\tbsr\t")) (pprImm imm)
1162 pprInstr (JSR reg addr n)
1164 ptext (sLit "\tjsr\t"),
1170 pprInstr (FUNBEGIN clab)
1172 if (externallyVisibleCLabel clab) then
1173 hcat [ptext (sLit "\t.globl\t"), pp_lab, char '\n']
1176 ptext (sLit "\t.ent "),
1185 pp_lab = pprCLabel_asm clab
1187 -- NEVER use commas within those string literals, cpp will ruin your day
1188 pp_ldgp = hcat [ ptext (sLit ":\n\tldgp $29"), char ',', ptext (sLit "0($27)\n") ]
1189 pp_frame = hcat [ ptext (sLit "..ng:\n\t.frame $30"), char ',',
1190 ptext (sLit "4240"), char ',',
1191 ptext (sLit "$26"), char ',',
1192 ptext (sLit "0\n\t.prologue 1") ]
1194 pprInstr (FUNEND clab)
1195 = (<>) (ptext (sLit "\t.align 4\n\t.end ")) (pprCLabel_asm clab)
1198 Continue with Alpha-only printing bits and bobs:
1202 pprRI (RIReg r) = pprReg r
1203 pprRI (RIImm r) = pprImm r
1205 pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
1206 pprRegRIReg name reg1 ri reg2
1218 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1219 pprSizeRegRegReg name size reg1 reg2 reg3
1232 #endif /* alpha_TARGET_ARCH */
1235 -- -----------------------------------------------------------------------------
1236 -- pprInstr for an x86
1238 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1240 pprInstr (SPILL reg slot)
1242 ptext (sLit "\tSPILL"),
1246 ptext (sLit "SLOT") <> parens (int slot)]
1248 pprInstr (RELOAD slot reg)
1250 ptext (sLit "\tRELOAD"),
1252 ptext (sLit "SLOT") <> parens (int slot),
1256 pprInstr (MOV size src dst)
1257 = pprSizeOpOp (sLit "mov") size src dst
1259 pprInstr (MOVZxL II32 src dst) = pprSizeOpOp (sLit "mov") II32 src dst
1260 -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple
1261 -- movl. But we represent it as a MOVZxL instruction, because
1262 -- the reg alloc would tend to throw away a plain reg-to-reg
1263 -- move, and we still want it to do that.
1265 pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce (sLit "movz") sizes II32 src dst
1266 -- zero-extension only needs to extend to 32 bits: on x86_64,
1267 -- the remaining zero-extension to 64 bits is automatic, and the 32-bit
1268 -- instruction is shorter.
1270 pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce (sLit "movs") sizes wordSize src dst
1272 -- here we do some patching, since the physical registers are only set late
1273 -- in the code generation.
1274 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1276 = pprSizeOpOp (sLit "add") size (OpReg reg2) dst
1277 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1279 = pprSizeOpOp (sLit "add") size (OpReg reg1) dst
1280 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))
1282 = pprInstr (ADD size (OpImm displ) dst)
1283 pprInstr (LEA size src dst) = pprSizeOpOp (sLit "lea") size src dst
1285 pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
1286 = pprSizeOp (sLit "dec") size dst
1287 pprInstr (ADD size (OpImm (ImmInt 1)) dst)
1288 = pprSizeOp (sLit "inc") size dst
1289 pprInstr (ADD size src dst)
1290 = pprSizeOpOp (sLit "add") size src dst
1291 pprInstr (ADC size src dst)
1292 = pprSizeOpOp (sLit "adc") size src dst
1293 pprInstr (SUB size src dst) = pprSizeOpOp (sLit "sub") size src dst
1294 pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2
1296 {- A hack. The Intel documentation says that "The two and three
1297 operand forms [of IMUL] may also be used with unsigned operands
1298 because the lower half of the product is the same regardless if
1299 (sic) the operands are signed or unsigned. The CF and OF flags,
1300 however, cannot be used to determine if the upper half of the
1301 result is non-zero." So there.
1303 pprInstr (AND size src dst) = pprSizeOpOp (sLit "and") size src dst
1304 pprInstr (OR size src dst) = pprSizeOpOp (sLit "or") size src dst
1306 pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst
1307 pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst
1308 pprInstr (XOR size src dst) = pprSizeOpOp (sLit "xor") size src dst
1310 pprInstr (NOT size op) = pprSizeOp (sLit "not") size op
1311 pprInstr (NEGI size op) = pprSizeOp (sLit "neg") size op
1313 pprInstr (SHL size src dst) = pprShift (sLit "shl") size src dst
1314 pprInstr (SAR size src dst) = pprShift (sLit "sar") size src dst
1315 pprInstr (SHR size src dst) = pprShift (sLit "shr") size src dst
1317 pprInstr (BT size imm src) = pprSizeImmOp (sLit "bt") size imm src
1319 pprInstr (CMP size src dst)
1320 | is_float size = pprSizeOpOp (sLit "ucomi") size src dst -- SSE2
1321 | otherwise = pprSizeOpOp (sLit "cmp") size src dst
1323 -- This predicate is needed here and nowhere else
1324 is_float FF32 = True
1325 is_float FF64 = True
1326 is_float FF80 = True
1327 is_float other = False
1329 pprInstr (TEST size src dst) = pprSizeOpOp (sLit "test") size src dst
1330 pprInstr (PUSH size op) = pprSizeOp (sLit "push") size op
1331 pprInstr (POP size op) = pprSizeOp (sLit "pop") size op
1333 -- both unused (SDM):
1334 -- pprInstr PUSHA = ptext (sLit "\tpushal")
1335 -- pprInstr POPA = ptext (sLit "\tpopal")
1337 pprInstr NOP = ptext (sLit "\tnop")
1338 pprInstr (CLTD II32) = ptext (sLit "\tcltd")
1339 pprInstr (CLTD II64) = ptext (sLit "\tcqto")
1341 pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op)
1343 pprInstr (JXX cond (BlockId id))
1344 = pprCondInstr (sLit "j") cond (pprCLabel_asm lab)
1345 where lab = mkAsmTempLabel id
1347 pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm)
1349 pprInstr (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm)
1350 pprInstr (JMP op) = (<>) (ptext (sLit "\tjmp *")) (pprOperand wordSize op)
1351 pprInstr (JMP_TBL op ids) = pprInstr (JMP op)
1352 pprInstr (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm)
1353 pprInstr (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg wordSize reg)
1355 pprInstr (IDIV sz op) = pprSizeOp (sLit "idiv") sz op
1356 pprInstr (DIV sz op) = pprSizeOp (sLit "div") sz op
1357 pprInstr (IMUL2 sz op) = pprSizeOp (sLit "imul") sz op
1359 #if x86_64_TARGET_ARCH
1360 pprInstr (MUL size op1 op2) = pprSizeOpOp (sLit "mul") size op1 op2
1362 pprInstr (FDIV size op1 op2) = pprSizeOpOp (sLit "div") size op1 op2
1364 pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to
1365 pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to
1366 pprInstr (CVTTSS2SIQ from to) = pprOpReg (sLit "cvttss2siq") from to
1367 pprInstr (CVTTSD2SIQ from to) = pprOpReg (sLit "cvttsd2siq") from to
1368 pprInstr (CVTSI2SS from to) = pprOpReg (sLit "cvtsi2ssq") from to
1369 pprInstr (CVTSI2SD from to) = pprOpReg (sLit "cvtsi2sdq") from to
1372 -- FETCHGOT for PIC on ELF platforms
1373 pprInstr (FETCHGOT reg)
1374 = vcat [ ptext (sLit "\tcall 1f"),
1375 hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ],
1376 hcat [ ptext (sLit "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "),
1380 -- FETCHPC for PIC on Darwin/x86
1381 -- get the instruction pointer into a register
1382 -- (Terminology note: the IP is called Program Counter on PPC,
1383 -- and it's a good thing to use the same name on both platforms)
1384 pprInstr (FETCHPC reg)
1385 = vcat [ ptext (sLit "\tcall 1f"),
1386 hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ]
1393 -- -----------------------------------------------------------------------------
1394 -- i386 floating-point
1396 #if i386_TARGET_ARCH
1397 -- Simulating a flat register set on the x86 FP stack is tricky.
1398 -- you have to free %st(7) before pushing anything on the FP reg stack
1399 -- so as to preclude the possibility of a FP stack overflow exception.
1400 pprInstr g@(GMOV src dst)
1404 = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
1406 -- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FSTP (dst+1)
1407 pprInstr g@(GLD sz addr dst)
1408 = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp,
1409 pprAddr addr, gsemi, gpop dst 1])
1411 -- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
1412 pprInstr g@(GST sz src addr)
1413 = pprG g (hcat [gtab, gpush src 0, gsemi,
1414 text "fstp", pprSize sz, gsp, pprAddr addr])
1416 pprInstr g@(GLDZ dst)
1417 = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1])
1418 pprInstr g@(GLD1 dst)
1419 = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1])
1421 pprInstr g@(GFTOI src dst)
1422 = pprInstr (GDTOI src dst)
1423 pprInstr g@(GDTOI src dst)
1425 hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"],
1426 hcat [gtab, gpush src 0],
1427 hcat [gtab, text "movzwl 4(%esp), ", reg,
1428 text " ; orl $0xC00, ", reg],
1429 hcat [gtab, text "movl ", reg, text ", 0(%esp) ; fldcw 0(%esp)"],
1430 hcat [gtab, text "fistpl 0(%esp)"],
1431 hcat [gtab, text "fldcw 4(%esp) ; movl 0(%esp), ", reg],
1432 hcat [gtab, text "addl $8, %esp"]
1435 reg = pprReg II32 dst
1437 pprInstr g@(GITOF src dst)
1438 = pprInstr (GITOD src dst)
1439 pprInstr g@(GITOD src dst)
1440 = pprG g (hcat [gtab, text "pushl ", pprReg II32 src,
1441 text " ; ffree %st(7); fildl (%esp) ; ",
1442 gpop dst 1, text " ; addl $4,%esp"])
1444 {- Gruesome swamp follows. If you're unfortunate enough to have ventured
1445 this far into the jungle AND you give a Rat's Ass (tm) what's going
1446 on, here's the deal. Generate code to do a floating point comparison
1447 of src1 and src2, of kind cond, and set the Zero flag if true.
1449 The complications are to do with handling NaNs correctly. We want the
1450 property that if either argument is NaN, then the result of the
1451 comparison is False ... except if we're comparing for inequality,
1452 in which case the answer is True.
1454 Here's how the general (non-inequality) case works. As an
1455 example, consider generating the an equality test:
1457 pushl %eax -- we need to mess with this
1458 <get src1 to top of FPU stack>
1459 fcomp <src2 location in FPU stack> and pop pushed src1
1460 -- Result of comparison is in FPU Status Register bits
1462 fstsw %ax -- Move FPU Status Reg to %ax
1463 sahf -- move C3 C2 C0 from %ax to integer flag reg
1464 -- now the serious magic begins
1465 setpo %ah -- %ah = if comparable(neither arg was NaN) then 1 else 0
1466 sete %al -- %al = if arg1 == arg2 then 1 else 0
1467 andb %ah,%al -- %al &= %ah
1468 -- so %al == 1 iff (comparable && same); else it holds 0
1469 decb %al -- %al == 0, ZeroFlag=1 iff (comparable && same);
1470 else %al == 0xFF, ZeroFlag=0
1471 -- the zero flag is now set as we desire.
1474 The special case of inequality differs thusly:
1476 setpe %ah -- %ah = if incomparable(either arg was NaN) then 1 else 0
1477 setne %al -- %al = if arg1 /= arg2 then 1 else 0
1478 orb %ah,%al -- %al = if (incomparable || different) then 1 else 0
1479 decb %al -- if (incomparable || different) then (%al == 0, ZF=1)
1480 else (%al == 0xFF, ZF=0)
1482 pprInstr g@(GCMP cond src1 src2)
1483 | case cond of { NE -> True; other -> False }
1485 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1486 hcat [gtab, text "fcomp ", greg src2 1,
1487 text "; fstsw %ax ; sahf ; setpe %ah"],
1488 hcat [gtab, text "setne %al ; ",
1489 text "orb %ah,%al ; decb %al ; popl %eax"]
1493 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1494 hcat [gtab, text "fcomp ", greg src2 1,
1495 text "; fstsw %ax ; sahf ; setpo %ah"],
1496 hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ; ",
1497 text "andb %ah,%al ; decb %al ; popl %eax"]
1500 {- On the 486, the flags set by FP compare are the unsigned ones!
1501 (This looks like a HACK to me. WDP 96/03)
1503 fix_FP_cond :: Cond -> Cond
1504 fix_FP_cond GE = GEU
1505 fix_FP_cond GTT = GU
1506 fix_FP_cond LTT = LU
1507 fix_FP_cond LE = LEU
1508 fix_FP_cond EQQ = EQQ
1510 -- there should be no others
1513 pprInstr g@(GABS sz src dst)
1514 = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
1515 pprInstr g@(GNEG sz src dst)
1516 = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
1518 pprInstr g@(GSQRT sz src dst)
1519 = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
1520 hcat [gtab, gcoerceto sz, gpop dst 1])
1521 pprInstr g@(GSIN sz l1 l2 src dst)
1522 = pprG g (pprTrigOp "fsin" False l1 l2 src dst sz)
1523 pprInstr g@(GCOS sz l1 l2 src dst)
1524 = pprG g (pprTrigOp "fcos" False l1 l2 src dst sz)
1525 pprInstr g@(GTAN sz l1 l2 src dst)
1526 = pprG g (pprTrigOp "fptan" True l1 l2 src dst sz)
1528 -- In the translations for GADD, GMUL, GSUB and GDIV,
1529 -- the first two cases are mere optimisations. The otherwise clause
1530 -- generates correct code under all circumstances.
1532 pprInstr g@(GADD sz src1 src2 dst)
1534 = pprG g (text "\t#GADD-xxxcase1" $$
1535 hcat [gtab, gpush src2 0,
1536 text " ; faddp %st(0),", greg src1 1])
1538 = pprG g (text "\t#GADD-xxxcase2" $$
1539 hcat [gtab, gpush src1 0,
1540 text " ; faddp %st(0),", greg src2 1])
1542 = pprG g (hcat [gtab, gpush src1 0,
1543 text " ; fadd ", greg src2 1, text ",%st(0)",
1547 pprInstr g@(GMUL sz src1 src2 dst)
1549 = pprG g (text "\t#GMUL-xxxcase1" $$
1550 hcat [gtab, gpush src2 0,
1551 text " ; fmulp %st(0),", greg src1 1])
1553 = pprG g (text "\t#GMUL-xxxcase2" $$
1554 hcat [gtab, gpush src1 0,
1555 text " ; fmulp %st(0),", greg src2 1])
1557 = pprG g (hcat [gtab, gpush src1 0,
1558 text " ; fmul ", greg src2 1, text ",%st(0)",
1562 pprInstr g@(GSUB sz src1 src2 dst)
1564 = pprG g (text "\t#GSUB-xxxcase1" $$
1565 hcat [gtab, gpush src2 0,
1566 text " ; fsubrp %st(0),", greg src1 1])
1568 = pprG g (text "\t#GSUB-xxxcase2" $$
1569 hcat [gtab, gpush src1 0,
1570 text " ; fsubp %st(0),", greg src2 1])
1572 = pprG g (hcat [gtab, gpush src1 0,
1573 text " ; fsub ", greg src2 1, text ",%st(0)",
1577 pprInstr g@(GDIV sz src1 src2 dst)
1579 = pprG g (text "\t#GDIV-xxxcase1" $$
1580 hcat [gtab, gpush src2 0,
1581 text " ; fdivrp %st(0),", greg src1 1])
1583 = pprG g (text "\t#GDIV-xxxcase2" $$
1584 hcat [gtab, gpush src1 0,
1585 text " ; fdivp %st(0),", greg src2 1])
1587 = pprG g (hcat [gtab, gpush src1 0,
1588 text " ; fdiv ", greg src2 1, text ",%st(0)",
1593 = vcat [ ptext (sLit "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
1594 ptext (sLit "\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)")
1597 pprTrigOp :: String -> Bool -> CLabel -> CLabel -> Reg -> Reg -> Size -> Doc
1598 pprTrigOp op -- fsin, fcos or fptan
1599 isTan -- we need a couple of extra steps if we're doing tan
1600 l1 l2 -- internal labels for us to use
1602 = -- We'll be needing %eax later on
1603 hcat [gtab, text "pushl %eax;"] $$
1604 -- tan is going to use an extra space on the FP stack
1605 (if isTan then hcat [gtab, text "ffree %st(6)"] else empty) $$
1606 -- First put the value in %st(0) and try to apply the op to it
1607 hcat [gpush src 0, text ("; " ++ op)] $$
1608 -- Now look to see if C2 was set (overflow, |value| >= 2^63)
1609 hcat [gtab, text "fnstsw %ax"] $$
1610 hcat [gtab, text "test $0x400,%eax"] $$
1611 -- If we were in bounds then jump to the end
1612 hcat [gtab, text "je " <> pprCLabel_asm l1] $$
1613 -- Otherwise we need to shrink the value. Start by
1614 -- loading pi, doubleing it (by adding it to itself),
1615 -- and then swapping pi with the value, so the value we
1616 -- want to apply op to is in %st(0) again
1617 hcat [gtab, text "ffree %st(7); fldpi"] $$
1618 hcat [gtab, text "fadd %st(0),%st"] $$
1619 hcat [gtab, text "fxch %st(1)"] $$
1620 -- Now we have a loop in which we make the value smaller,
1621 -- see if it's small enough, and loop if not
1622 (pprCLabel_asm l2 <> char ':') $$
1623 hcat [gtab, text "fprem1"] $$
1624 -- My Debian libc uses fstsw here for the tan code, but I can't
1625 -- see any reason why it should need to be different for tan.
1626 hcat [gtab, text "fnstsw %ax"] $$
1627 hcat [gtab, text "test $0x400,%eax"] $$
1628 hcat [gtab, text "jne " <> pprCLabel_asm l2] $$
1629 hcat [gtab, text "fstp %st(1)"] $$
1630 hcat [gtab, text op] $$
1631 (pprCLabel_asm l1 <> char ':') $$
1632 -- Pop the 1.0 tan gave us
1633 (if isTan then hcat [gtab, text "fstp %st(0)"] else empty) $$
1635 hcat [gtab, text "popl %eax;"] $$
1636 -- And finally make the result the right size
1637 hcat [gtab, gcoerceto sz, gpop dst 1]
1639 --------------------------
1641 -- coerce %st(0) to the specified size
1642 gcoerceto FF64 = empty
1643 gcoerceto FF32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
1646 = hcat [text "ffree %st(7) ; fld ", greg reg offset]
1648 = hcat [text "fstp ", greg reg offset]
1650 greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
1655 gregno (RealReg i) = i
1656 gregno other = --pprPanic "gregno" (ppr other)
1657 999 -- bogus; only needed for debug printing
1659 pprG :: Instr -> Doc -> Doc
1661 = (char '#' <> pprGInstr fake) $$ actual
1663 pprGInstr (GMOV src dst) = pprSizeRegReg (sLit "gmov") FF64 src dst
1664 pprGInstr (GLD sz src dst) = pprSizeAddrReg (sLit "gld") sz src dst
1665 pprGInstr (GST sz src dst) = pprSizeRegAddr (sLit "gst") sz src dst
1667 pprGInstr (GLDZ dst) = pprSizeReg (sLit "gldz") FF64 dst
1668 pprGInstr (GLD1 dst) = pprSizeReg (sLit "gld1") FF64 dst
1670 pprGInstr (GFTOI src dst) = pprSizeSizeRegReg (sLit "gftoi") FF32 II32 src dst
1671 pprGInstr (GDTOI src dst) = pprSizeSizeRegReg (sLit "gdtoi") FF64 II32 src dst
1673 pprGInstr (GITOF src dst) = pprSizeSizeRegReg (sLit "gitof") II32 FF32 src dst
1674 pprGInstr (GITOD src dst) = pprSizeSizeRegReg (sLit "gitod") II32 FF64 src dst
1676 pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 co src dst
1677 pprGInstr (GABS sz src dst) = pprSizeRegReg (sLit "gabs") sz src dst
1678 pprGInstr (GNEG sz src dst) = pprSizeRegReg (sLit "gneg") sz src dst
1679 pprGInstr (GSQRT sz src dst) = pprSizeRegReg (sLit "gsqrt") sz src dst
1680 pprGInstr (GSIN sz _ _ src dst) = pprSizeRegReg (sLit "gsin") sz src dst
1681 pprGInstr (GCOS sz _ _ src dst) = pprSizeRegReg (sLit "gcos") sz src dst
1682 pprGInstr (GTAN sz _ _ src dst) = pprSizeRegReg (sLit "gtan") sz src dst
1684 pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg (sLit "gadd") sz src1 src2 dst
1685 pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg (sLit "gsub") sz src1 src2 dst
1686 pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg (sLit "gmul") sz src1 src2 dst
1687 pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg (sLit "gdiv") sz src1 src2 dst
1690 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1692 -- Continue with I386-only printing bits and bobs:
1694 pprDollImm :: Imm -> Doc
1696 pprDollImm i = ptext (sLit "$") <> pprImm i
1698 pprOperand :: Size -> Operand -> Doc
1699 pprOperand s (OpReg r) = pprReg s r
1700 pprOperand s (OpImm i) = pprDollImm i
1701 pprOperand s (OpAddr ea) = pprAddr ea
1703 pprMnemonic_ :: LitString -> Doc
1705 char '\t' <> ptext name <> space
1707 pprMnemonic :: LitString -> Size -> Doc
1708 pprMnemonic name size =
1709 char '\t' <> ptext name <> pprSize size <> space
1711 pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc
1712 pprSizeImmOp name size imm op1
1714 pprMnemonic name size,
1721 pprSizeOp :: LitString -> Size -> Operand -> Doc
1722 pprSizeOp name size op1
1724 pprMnemonic name size,
1728 pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1729 pprSizeOpOp name size op1 op2
1731 pprMnemonic name size,
1732 pprOperand size op1,
1737 pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1738 pprOpOp name size op1 op2
1741 pprOperand size op1,
1746 pprSizeReg :: LitString -> Size -> Reg -> Doc
1747 pprSizeReg name size reg1
1749 pprMnemonic name size,
1753 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
1754 pprSizeRegReg name size reg1 reg2
1756 pprMnemonic name size,
1762 pprRegReg :: LitString -> Reg -> Reg -> Doc
1763 pprRegReg name reg1 reg2
1766 pprReg wordSize reg1,
1768 pprReg wordSize reg2
1771 pprOpReg :: LitString -> Operand -> Reg -> Doc
1772 pprOpReg name op1 reg2
1775 pprOperand wordSize op1,
1777 pprReg wordSize reg2
1780 pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc
1781 pprCondRegReg name size cond reg1 reg2
1792 pprSizeSizeRegReg :: LitString -> Size -> Size -> Reg -> Reg -> Doc
1793 pprSizeSizeRegReg name size1 size2 reg1 reg2
1806 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1807 pprSizeRegRegReg name size reg1 reg2 reg3
1809 pprMnemonic name size,
1817 pprSizeAddrReg :: LitString -> Size -> AddrMode -> Reg -> Doc
1818 pprSizeAddrReg name size op dst
1820 pprMnemonic name size,
1826 pprSizeRegAddr :: LitString -> Size -> Reg -> AddrMode -> Doc
1827 pprSizeRegAddr name size src op
1829 pprMnemonic name size,
1835 pprShift :: LitString -> Size -> Operand -> Operand -> Doc
1836 pprShift name size src dest
1838 pprMnemonic name size,
1839 pprOperand II8 src, -- src is 8-bit sized
1841 pprOperand size dest
1844 pprSizeOpOpCoerce :: LitString -> Size -> Size -> Operand -> Operand -> Doc
1845 pprSizeOpOpCoerce name size1 size2 op1 op2
1846 = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
1847 pprOperand size1 op1,
1849 pprOperand size2 op2
1852 pprCondInstr :: LitString -> Cond -> Doc -> Doc
1853 pprCondInstr name cond arg
1854 = hcat [ char '\t', ptext name, pprCond cond, space, arg]
1856 #endif /* i386_TARGET_ARCH */
1859 -- ------------------------------------------------------------------------------- pprInstr for a SPARC
1861 #if sparc_TARGET_ARCH
1863 -- a clumsy hack for now, to handle possible double alignment problems
1865 -- even clumsier, to allow for RegReg regs that show when doing indexed
1866 -- reads (bytearrays).
1869 pprInstr (SPILL reg slot)
1871 ptext (sLit "\tSPILL"),
1875 ptext (sLit "SLOT") <> parens (int slot)]
1877 pprInstr (RELOAD slot reg)
1879 ptext (sLit "\tRELOAD"),
1881 ptext (sLit "SLOT") <> parens (int slot),
1885 -- Translate to the following:
1888 -- ld [g1+4],%f(n+1)
1889 -- sub g1,g2,g1 -- to restore g1
1891 pprInstr (LD FF64 (AddrRegReg g1 g2) reg)
1892 = let Just regH = fPair reg
1894 hcat [ptext (sLit "\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1895 hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg],
1896 hcat [pp_ld_lbracket, pprReg g1, ptext (sLit "+4]"), comma, pprReg regH],
1897 hcat [ptext (sLit "\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1902 -- ld [addr+4],%f(n+1)
1903 pprInstr (LD FF64 addr reg)
1904 = let Just addr2 = addrOffset addr 4
1905 Just regH = fPair reg
1907 hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
1908 hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg regH]
1912 pprInstr (LD size addr reg)
1914 ptext (sLit "\tld"),
1923 -- The same clumsy hack as above
1925 -- Translate to the following:
1928 -- st %f(n+1),[g1+4]
1929 -- sub g1,g2,g1 -- to restore g1
1930 pprInstr (ST FF64 reg (AddrRegReg g1 g2))
1931 = let Just regH = fPair reg
1933 hcat [ptext (sLit "\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1934 hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket,
1936 hcat [ptext (sLit "\tst\t"), pprReg regH, pp_comma_lbracket,
1937 pprReg g1, ptext (sLit "+4]")],
1938 hcat [ptext (sLit "\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1943 -- st %f(n+1),[addr+4]
1944 pprInstr instr@(ST FF64 reg addr)
1945 = let Just addr2 = addrOffset addr 4
1946 Just regH = fPair reg
1948 hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket,
1949 pprAddr addr, rbrack],
1950 hcat [ptext (sLit "\tst\t"), pprReg regH, pp_comma_lbracket,
1951 pprAddr addr2, rbrack]
1956 -- no distinction is made between signed and unsigned bytes on stores for the
1957 -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
1958 -- so we call a special-purpose pprSize for ST..
1960 pprInstr (ST size reg addr)
1962 ptext (sLit "\tst"),
1971 pprInstr (ADD x cc reg1 ri reg2)
1972 | not x && not cc && riZero ri
1973 = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1976 = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2
1978 pprInstr (SUB x cc reg1 ri reg2)
1979 | not x && cc && reg2 == g0
1980 = hcat [ ptext (sLit "\tcmp\t"), pprReg reg1, comma, pprRI ri ]
1981 | not x && not cc && riZero ri
1982 = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1984 = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2
1986 pprInstr (AND b reg1 ri reg2) = pprRegRIReg (sLit "and") b reg1 ri reg2
1987 pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2
1989 pprInstr (OR b reg1 ri reg2)
1990 | not b && reg1 == g0
1991 = let doit = hcat [ ptext (sLit "\tmov\t"), pprRI ri, comma, pprReg reg2 ]
1993 RIReg rrr | rrr == reg2 -> empty
1997 = pprRegRIReg (sLit "or") b reg1 ri reg2
1999 pprInstr (ORN b reg1 ri reg2) = pprRegRIReg (sLit "orn") b reg1 ri reg2
2001 pprInstr (XOR b reg1 ri reg2) = pprRegRIReg (sLit "xor") b reg1 ri reg2
2002 pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg (sLit "xnor") b reg1 ri reg2
2004 pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") False reg1 ri reg2
2005 pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") False reg1 ri reg2
2006 pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") False reg1 ri reg2
2008 pprInstr (RDY rd) = ptext (sLit "\trd\t%y,") <> pprReg rd
2009 pprInstr (WRY reg1 reg2)
2010 = ptext (sLit "\twr\t")
2015 <> ptext (sLit "%y")
2017 pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul") b reg1 ri reg2
2018 pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul") b reg1 ri reg2
2019 pprInstr (SDIV b reg1 ri reg2) = pprRegRIReg (sLit "sdiv") b reg1 ri reg2
2020 pprInstr (UDIV b reg1 ri reg2) = pprRegRIReg (sLit "udiv") b reg1 ri reg2
2022 pprInstr (SETHI imm reg)
2024 ptext (sLit "\tsethi\t"),
2030 pprInstr NOP = ptext (sLit "\tnop")
2032 pprInstr (FABS FF32 reg1 reg2) = pprSizeRegReg (sLit "fabs") FF32 reg1 reg2
2033 pprInstr (FABS FF64 reg1 reg2)
2034 = let Just reg1H = fPair reg1
2035 Just reg2H = fPair reg2
2037 (<>) (pprSizeRegReg (sLit "fabs") FF32 reg1 reg2)
2038 (if (reg1 == reg2) then empty
2039 else (<>) (char '\n')
2040 (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
2042 pprInstr (FADD size reg1 reg2 reg3)
2043 = pprSizeRegRegReg (sLit "fadd") size reg1 reg2 reg3
2044 pprInstr (FCMP e size reg1 reg2)
2045 = pprSizeRegReg (if e then sLit "fcmpe" else sLit "fcmp") size reg1 reg2
2046 pprInstr (FDIV size reg1 reg2 reg3)
2047 = pprSizeRegRegReg (sLit "fdiv") size reg1 reg2 reg3
2049 pprInstr (FMOV FF32 reg1 reg2) = pprSizeRegReg (sLit "fmov") FF32 reg1 reg2
2050 pprInstr (FMOV FF64 reg1 reg2) = pprSizeRegReg (sLit "fmov") FF64 reg1 reg2
2053 pprInstr (FMOV FF64 reg1 reg2)
2054 = let Just reg1H = fPair reg1
2055 Just reg2H = fPair reg2
2057 (<>) (pprSizeRegReg (sLit "fmov") FF32 reg1 reg2)
2058 (if (reg1 == reg2) then empty
2059 else (<>) (char '\n')
2060 (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
2063 pprInstr (FMUL size reg1 reg2 reg3)
2064 = pprSizeRegRegReg (sLit "fmul") size reg1 reg2 reg3
2066 pprInstr (FNEG FF32 reg1 reg2) = pprSizeRegReg (sLit "fneg") FF32 reg1 reg2
2067 pprInstr (FNEG FF64 reg1 reg2)
2068 = let Just reg1H = fPair reg1
2069 Just reg2H = fPair reg2
2071 (<>) (pprSizeRegReg (sLit "fneg") FF32 reg1 reg2)
2072 (if (reg1 == reg2) then empty
2073 else (<>) (char '\n')
2074 (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
2076 pprInstr (FSQRT size reg1 reg2) = pprSizeRegReg (sLit "fsqrt") size reg1 reg2
2077 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fsub") size reg1 reg2 reg3
2078 pprInstr (FxTOy size1 size2 reg1 reg2)
2085 FF64 -> sLit "dto"),
2091 FF64 -> sLit "d\t"),
2092 pprReg reg1, comma, pprReg reg2
2096 pprInstr (BI cond b (BlockId id))
2098 ptext (sLit "\tb"), pprCond cond,
2099 if b then pp_comma_a else empty,
2101 pprCLabel_asm (mkAsmTempLabel id)
2104 pprInstr (BF cond b (BlockId id))
2106 ptext (sLit "\tfb"), pprCond cond,
2107 if b then pp_comma_a else empty,
2109 pprCLabel_asm (mkAsmTempLabel id)
2112 pprInstr (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr addr)
2114 pprInstr (CALL (Left imm) n _)
2115 = hcat [ ptext (sLit "\tcall\t"), pprImm imm, comma, int n ]
2116 pprInstr (CALL (Right reg) n _)
2117 = hcat [ ptext (sLit "\tcall\t"), pprReg reg, comma, int n ]
2120 pprRI (RIReg r) = pprReg r
2121 pprRI (RIImm r) = pprImm r
2123 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
2124 pprSizeRegReg name size reg1 reg2
2129 FF32 -> ptext (sLit "s\t")
2130 FF64 -> ptext (sLit "d\t")),
2136 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
2137 pprSizeRegRegReg name size reg1 reg2 reg3
2142 FF32 -> ptext (sLit "s\t")
2143 FF64 -> ptext (sLit "d\t")),
2151 pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
2152 pprRegRIReg name b reg1 ri reg2
2156 if b then ptext (sLit "cc\t") else char '\t',
2164 pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
2165 pprRIReg name b ri reg1
2169 if b then ptext (sLit "cc\t") else char '\t',
2175 pp_ld_lbracket = ptext (sLit "\tld\t[")
2176 pp_rbracket_comma = text "],"
2177 pp_comma_lbracket = text ",["
2178 pp_comma_a = text ",a"
2180 #endif /* sparc_TARGET_ARCH */
2183 -- -----------------------------------------------------------------------------
2184 -- pprInstr for PowerPC
2186 #if powerpc_TARGET_ARCH
2188 pprInstr (SPILL reg slot)
2190 ptext (sLit "\tSPILL"),
2194 ptext (sLit "SLOT") <> parens (int slot)]
2196 pprInstr (RELOAD slot reg)
2198 ptext (sLit "\tRELOAD"),
2200 ptext (sLit "SLOT") <> parens (int slot),
2204 pprInstr (LD sz reg addr) = hcat [
2213 case addr of AddrRegImm _ _ -> empty
2214 AddrRegReg _ _ -> char 'x',
2220 pprInstr (LA sz reg addr) = hcat [
2229 case addr of AddrRegImm _ _ -> empty
2230 AddrRegReg _ _ -> char 'x',
2236 pprInstr (ST sz reg addr) = hcat [
2240 case addr of AddrRegImm _ _ -> empty
2241 AddrRegReg _ _ -> char 'x',
2247 pprInstr (STU sz reg addr) = hcat [
2252 case addr of AddrRegImm _ _ -> empty
2253 AddrRegReg _ _ -> char 'x',
2258 pprInstr (LIS reg imm) = hcat [
2266 pprInstr (LI reg imm) = hcat [
2274 pprInstr (MR reg1 reg2)
2275 | reg1 == reg2 = empty
2276 | otherwise = hcat [
2278 case regClass reg1 of
2279 RcInteger -> ptext (sLit "mr")
2280 _ -> ptext (sLit "fmr"),
2286 pprInstr (CMP sz reg ri) = hcat [
2302 pprInstr (CMPL sz reg ri) = hcat [
2312 ptext (sLit "cmpl"),
2318 pprInstr (BCC cond (BlockId id)) = hcat [
2325 where lbl = mkAsmTempLabel id
2327 pprInstr (BCCFAR cond (BlockId id)) = vcat [
2330 pprCond (condNegate cond),
2331 ptext (sLit "\t$+8")
2334 ptext (sLit "\tb\t"),
2338 where lbl = mkAsmTempLabel id
2340 pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
2347 pprInstr (MTCTR reg) = hcat [
2349 ptext (sLit "mtctr"),
2353 pprInstr (BCTR _) = hcat [
2357 pprInstr (BL lbl _) = hcat [
2358 ptext (sLit "\tbl\t"),
2361 pprInstr (BCTRL _) = hcat [
2363 ptext (sLit "bctrl")
2365 pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri
2366 pprInstr (ADDIS reg1 reg2 imm) = hcat [
2368 ptext (sLit "addis"),
2377 pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3)
2378 pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3)
2379 pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3)
2380 pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri
2381 pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri
2382 pprInstr (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3)
2383 pprInstr (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3)
2385 pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
2386 hcat [ ptext (sLit "\tmullwo\t"), pprReg reg1, ptext (sLit ", "),
2387 pprReg reg2, ptext (sLit ", "),
2389 hcat [ ptext (sLit "\tmfxer\t"), pprReg reg1 ],
2390 hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "),
2391 pprReg reg1, ptext (sLit ", "),
2392 ptext (sLit "2, 31, 31") ]
2395 -- for some reason, "andi" doesn't exist.
2396 -- we'll use "andi." instead.
2397 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
2399 ptext (sLit "andi."),
2407 pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri
2409 pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri
2410 pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri
2412 pprInstr (XORIS reg1 reg2 imm) = hcat [
2414 ptext (sLit "xoris"),
2423 pprInstr (EXTS sz reg1 reg2) = hcat [
2425 ptext (sLit "exts"),
2433 pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2
2434 pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2
2436 pprInstr (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri)
2437 pprInstr (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri)
2438 pprInstr (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri)
2439 pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
2440 ptext (sLit "\trlwinm\t"),
2452 pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF (sLit "fadd") sz reg1 reg2 reg3
2453 pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF (sLit "fsub") sz reg1 reg2 reg3
2454 pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF (sLit "fmul") sz reg1 reg2 reg3
2455 pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") sz reg1 reg2 reg3
2456 pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2
2458 pprInstr (FCMP reg1 reg2) = hcat [
2460 ptext (sLit "fcmpu\tcr0, "),
2461 -- Note: we're using fcmpu, not fcmpo
2462 -- The difference is with fcmpo, compare with NaN is an invalid operation.
2463 -- We don't handle invalid fp ops, so we don't care
2469 pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2
2470 pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2
2472 pprInstr (CRNOR dst src1 src2) = hcat [
2473 ptext (sLit "\tcrnor\t"),
2481 pprInstr (MFCR reg) = hcat [
2483 ptext (sLit "mfcr"),
2488 pprInstr (MFLR reg) = hcat [
2490 ptext (sLit "mflr"),
2495 pprInstr (FETCHPC reg) = vcat [
2496 ptext (sLit "\tbcl\t20,31,1f"),
2497 hcat [ ptext (sLit "1:\tmflr\t"), pprReg reg ]
2500 pprInstr LWSYNC = ptext (sLit "\tlwsync")
2502 pprInstr _ = panic "pprInstr (ppc)"
2504 pprLogic op reg1 reg2 ri = hcat [
2509 RIImm _ -> char 'i',
2518 pprUnary op reg1 reg2 = hcat [
2527 pprBinaryF op sz reg1 reg2 reg3 = hcat [
2540 pprRI (RIReg r) = pprReg r
2541 pprRI (RIImm r) = pprImm r
2543 pprFSize FF64 = empty
2544 pprFSize FF32 = char 's'
2546 -- limit immediate argument for shift instruction to range 0..32
2547 -- (yes, the maximum is really 32, not 31)
2548 limitShiftRI :: RI -> RI
2549 limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32)
2552 #endif /* powerpc_TARGET_ARCH */
2555 -- -----------------------------------------------------------------------------
2556 -- Converting floating-point literals to integrals for printing
2558 castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)
2559 castFloatToWord8Array = castSTUArray
2561 castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8)
2562 castDoubleToWord8Array = castSTUArray
2564 -- floatToBytes and doubleToBytes convert to the host's byte
2565 -- order. Providing that we're not cross-compiling for a
2566 -- target with the opposite endianness, this should work ok
2569 -- ToDo: this stuff is very similar to the shenanigans in PprAbs,
2570 -- could they be merged?
2572 floatToBytes :: Float -> [Int]
2575 arr <- newArray_ ((0::Int),3)
2577 arr <- castFloatToWord8Array arr
2578 i0 <- readArray arr 0
2579 i1 <- readArray arr 1
2580 i2 <- readArray arr 2
2581 i3 <- readArray arr 3
2582 return (map fromIntegral [i0,i1,i2,i3])
2585 doubleToBytes :: Double -> [Int]
2588 arr <- newArray_ ((0::Int),7)
2590 arr <- castDoubleToWord8Array arr
2591 i0 <- readArray arr 0
2592 i1 <- readArray arr 1
2593 i2 <- readArray arr 2
2594 i3 <- readArray arr 3
2595 i4 <- readArray arr 4
2596 i5 <- readArray arr 5
2597 i6 <- readArray arr 6
2598 i7 <- readArray arr 7
2599 return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7])