2 -- The above warning supression flag is a temporary kludge.
3 -- While working on this module you are encouraged to remove it and fix
4 -- any warnings in the module. See
5 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
8 -----------------------------------------------------------------------------
10 -- Pretty-printing assembly language
12 -- (c) The University of Glasgow 1993-2005
14 -----------------------------------------------------------------------------
16 -- We start with the @pprXXX@s with some cross-platform commonality
17 -- (e.g., 'pprReg'); we conclude with the no-commonality monster,
20 #include "nativeGen/NCG.h"
23 pprNatCmmTop, pprBasicBlock, pprSectionHeader, pprData,
24 pprInstr, pprSize, pprUserReg
27 #include "HsVersions.h"
31 import MachRegs -- may differ per-platform
34 import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel,
35 labelDynamic, mkAsmTempLabel, entryLblToInfoLbl )
36 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
37 import CLabel ( mkDeadStripPreventer )
40 import Panic ( panic )
41 import Unique ( pprUnique )
44 import qualified Outputable
45 import Outputable ( Outputable )
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 -- -----------------------------------------------------------------------------
357 -- pprSize: print a 'Size'
359 #if powerpc_TARGET_ARCH || i386_TARGET_ARCH || x86_64_TARGET_ARCH || sparc_TARGET_ARCH
360 pprSize :: Size -> Doc
362 pprSize :: Size -> Doc
365 pprSize x = ptext (case x of
366 #if alpha_TARGET_ARCH
369 -- W -> sLit "w" UNUSED
370 -- Wu -> sLit "wu" UNUSED
373 -- FF -> sLit "f" UNUSED
374 -- DF -> sLit "d" UNUSED
375 -- GF -> sLit "g" UNUSED
376 -- SF -> sLit "s" UNUSED
379 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
390 #if x86_64_TARGET_ARCH
391 FF32 -> sLit "ss" -- "scalar single-precision float" (SSE2)
392 FF64 -> sLit "sd" -- "scalar double-precision float" (SSE2)
394 #if sparc_TARGET_ARCH
401 pprStSize :: Size -> Doc
402 pprStSize x = ptext (case x of
409 #if powerpc_TARGET_ARCH
418 -- -----------------------------------------------------------------------------
419 -- pprCond: print a 'Cond'
421 pprCond :: Cond -> Doc
423 pprCond c = ptext (case c of {
424 #if alpha_TARGET_ARCH
434 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
435 GEU -> sLit "ae"; LU -> sLit "b";
436 EQQ -> sLit "e"; GTT -> sLit "g";
437 GE -> sLit "ge"; GU -> sLit "a";
438 LTT -> sLit "l"; LE -> sLit "le";
439 LEU -> sLit "be"; NE -> sLit "ne";
440 NEG -> sLit "s"; POS -> sLit "ns";
441 CARRY -> sLit "c"; OFLO -> sLit "o";
442 PARITY -> sLit "p"; NOTPARITY -> sLit "np";
443 ALWAYS -> sLit "mp" -- hack
445 #if sparc_TARGET_ARCH
446 ALWAYS -> sLit ""; NEVER -> sLit "n";
447 GEU -> sLit "geu"; LU -> sLit "lu";
448 EQQ -> sLit "e"; GTT -> sLit "g";
449 GE -> sLit "ge"; GU -> sLit "gu";
450 LTT -> sLit "l"; LE -> sLit "le";
451 LEU -> sLit "leu"; NE -> sLit "ne";
452 NEG -> sLit "neg"; POS -> sLit "pos";
453 VC -> sLit "vc"; VS -> sLit "vs"
455 #if powerpc_TARGET_ARCH
457 EQQ -> sLit "eq"; NE -> sLit "ne";
458 LTT -> sLit "lt"; GE -> sLit "ge";
459 GTT -> sLit "gt"; LE -> sLit "le";
460 LU -> sLit "lt"; GEU -> sLit "ge";
461 GU -> sLit "gt"; LEU -> sLit "le";
466 -- -----------------------------------------------------------------------------
467 -- pprImm: print an 'Imm'
471 pprImm (ImmInt i) = int i
472 pprImm (ImmInteger i) = integer i
473 pprImm (ImmCLbl l) = pprCLabel_asm l
474 pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i
475 pprImm (ImmLit s) = s
477 pprImm (ImmFloat _) = ptext (sLit "naughty float immediate")
478 pprImm (ImmDouble _) = ptext (sLit "naughty double immediate")
480 pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
481 #if sparc_TARGET_ARCH
482 -- ToDo: This should really be fixed in the PIC support, but only
484 pprImm (ImmConstantDiff a b) = pprImm a
486 pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
487 <> lparen <> pprImm b <> rparen
490 #if sparc_TARGET_ARCH
492 = hcat [ pp_lo, pprImm i, rparen ]
497 = hcat [ pp_hi, pprImm i, rparen ]
501 #if powerpc_TARGET_ARCH
504 = hcat [ pp_lo, pprImm i, rparen ]
509 = hcat [ pp_hi, pprImm i, rparen ]
514 = hcat [ pp_ha, pprImm i, rparen ]
520 = pprImm i <> text "@l"
523 = pprImm i <> text "@h"
526 = pprImm i <> text "@ha"
531 -- -----------------------------------------------------------------------------
532 -- @pprAddr: print an 'AddrMode'
534 pprAddr :: AddrMode -> Doc
536 #if alpha_TARGET_ARCH
537 pprAddr (AddrReg r) = parens (pprReg r)
538 pprAddr (AddrImm i) = pprImm i
539 pprAddr (AddrRegImm r1 i)
540 = (<>) (pprImm i) (parens (pprReg r1))
545 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
546 pprAddr (ImmAddr imm off)
547 = let pp_imm = pprImm imm
551 else if (off < 0) then
554 pp_imm <> char '+' <> int off
556 pprAddr (AddrBaseIndex base index displacement)
558 pp_disp = ppr_disp displacement
559 pp_off p = pp_disp <> char '(' <> p <> char ')'
560 pp_reg r = pprReg wordSize r
563 (EABaseNone, EAIndexNone) -> pp_disp
564 (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b)
565 (EABaseRip, EAIndexNone) -> pp_off (ptext (sLit "%rip"))
566 (EABaseNone, EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i)
567 (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r
570 ppr_disp (ImmInt 0) = empty
571 ppr_disp imm = pprImm imm
576 #if sparc_TARGET_ARCH
577 pprAddr (AddrRegReg r1 (RealReg 0)) = pprReg r1
579 pprAddr (AddrRegReg r1 r2)
580 = hcat [ pprReg r1, char '+', pprReg r2 ]
582 pprAddr (AddrRegImm r1 (ImmInt i))
584 | not (fits13Bits i) = largeOffsetError i
585 | otherwise = hcat [ pprReg r1, pp_sign, int i ]
587 pp_sign = if i > 0 then char '+' else empty
589 pprAddr (AddrRegImm r1 (ImmInteger i))
591 | not (fits13Bits i) = largeOffsetError i
592 | otherwise = hcat [ pprReg r1, pp_sign, integer i ]
594 pp_sign = if i > 0 then char '+' else empty
596 pprAddr (AddrRegImm r1 imm)
597 = hcat [ pprReg r1, char '+', pprImm imm ]
602 #if powerpc_TARGET_ARCH
603 pprAddr (AddrRegReg r1 r2)
604 = pprReg r1 <+> ptext (sLit ", ") <+> pprReg r2
606 pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ]
607 pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ]
608 pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]
612 -- -----------------------------------------------------------------------------
613 -- pprData: print a 'CmmStatic'
615 pprSectionHeader Text
617 (IF_ARCH_alpha(sLit "\t.text\n\t.align 3" {-word boundary-}
618 ,IF_ARCH_sparc(sLit ".text\n\t.align 4" {-word boundary-}
619 ,IF_ARCH_i386(IF_OS_darwin(sLit ".text\n\t.align 2",
620 sLit ".text\n\t.align 4,0x90")
621 {-needs per-OS variation!-}
622 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".text\n.align 3",
623 sLit ".text\n\t.align 8")
624 ,IF_ARCH_powerpc(sLit ".text\n.align 2"
626 pprSectionHeader Data
628 (IF_ARCH_alpha(sLit "\t.data\n\t.align 3"
629 ,IF_ARCH_sparc(sLit ".data\n\t.align 8" {-<8 will break double constants -}
630 ,IF_ARCH_i386(IF_OS_darwin(sLit ".data\n\t.align 2",
631 sLit ".data\n\t.align 4")
632 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".data\n.align 3",
633 sLit ".data\n\t.align 8")
634 ,IF_ARCH_powerpc(sLit ".data\n.align 2"
636 pprSectionHeader ReadOnlyData
638 (IF_ARCH_alpha(sLit "\t.data\n\t.align 3"
639 ,IF_ARCH_sparc(sLit ".data\n\t.align 8" {-<8 will break double constants -}
640 ,IF_ARCH_i386(IF_OS_darwin(sLit ".const\n.align 2",
641 sLit ".section .rodata\n\t.align 4")
642 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".const\n.align 3",
643 sLit ".section .rodata\n\t.align 8")
644 ,IF_ARCH_powerpc(IF_OS_darwin(sLit ".const\n.align 2",
645 sLit ".section .rodata\n\t.align 2")
647 pprSectionHeader RelocatableReadOnlyData
649 (IF_ARCH_alpha(sLit "\t.data\n\t.align 3"
650 ,IF_ARCH_sparc(sLit ".data\n\t.align 8" {-<8 will break double constants -}
651 ,IF_ARCH_i386(IF_OS_darwin(sLit ".const_data\n.align 2",
652 sLit ".section .data\n\t.align 4")
653 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".const_data\n.align 3",
654 sLit ".section .data\n\t.align 8")
655 ,IF_ARCH_powerpc(IF_OS_darwin(sLit ".const_data\n.align 2",
656 sLit ".data\n\t.align 2")
658 pprSectionHeader UninitialisedData
660 (IF_ARCH_alpha(sLit "\t.bss\n\t.align 3"
661 ,IF_ARCH_sparc(sLit ".bss\n\t.align 8" {-<8 will break double constants -}
662 ,IF_ARCH_i386(IF_OS_darwin(sLit ".data\n\t.align 2",
663 sLit ".section .bss\n\t.align 4")
664 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".data\n\t.align 3",
665 sLit ".section .bss\n\t.align 8")
666 ,IF_ARCH_powerpc(IF_OS_darwin(sLit ".const_data\n.align 2",
667 sLit ".section .bss\n\t.align 2")
669 pprSectionHeader ReadOnlyData16
671 (IF_ARCH_alpha(sLit "\t.data\n\t.align 4"
672 ,IF_ARCH_sparc(sLit ".data\n\t.align 16"
673 ,IF_ARCH_i386(IF_OS_darwin(sLit ".const\n.align 4",
674 sLit ".section .rodata\n\t.align 16")
675 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".const\n.align 4",
676 sLit ".section .rodata.cst16\n\t.align 16")
677 ,IF_ARCH_powerpc(IF_OS_darwin(sLit ".const\n.align 4",
678 sLit ".section .rodata\n\t.align 4")
681 pprSectionHeader (OtherSection sec)
682 = panic "PprMach.pprSectionHeader: unknown section"
684 pprData :: CmmStatic -> Doc
685 pprData (CmmAlign bytes) = pprAlign bytes
686 pprData (CmmDataLabel lbl) = pprLabel lbl
687 pprData (CmmString str) = pprASCII str
688 pprData (CmmUninitialised bytes) = ptext (sLit ".space ") <> int bytes
689 pprData (CmmStaticLit lit) = pprDataItem lit
691 pprGloblDecl :: CLabel -> Doc
693 | not (externallyVisibleCLabel lbl) = empty
694 | otherwise = ptext IF_ARCH_sparc((sLit ".global "),
698 pprTypeAndSizeDecl :: CLabel -> Doc
699 pprTypeAndSizeDecl lbl
701 | not (externallyVisibleCLabel lbl) = empty
702 | otherwise = ptext (sLit ".type ") <>
703 pprCLabel_asm lbl <> ptext (sLit ", @object")
708 pprLabel :: CLabel -> Doc
709 pprLabel lbl = pprGloblDecl lbl $$ pprTypeAndSizeDecl lbl $$ (pprCLabel_asm lbl <> char ':')
713 = vcat (map do1 str) $$ do1 0
716 do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w)
719 IF_ARCH_alpha(ptext (sLit ".align ") <> int pow2,
720 IF_ARCH_i386(ptext (sLit ".align ") <> int IF_OS_darwin(pow2,bytes),
721 IF_ARCH_x86_64(ptext (sLit ".align ") <> int IF_OS_darwin(pow2,bytes),
722 IF_ARCH_sparc(ptext (sLit ".align ") <> int bytes,
723 IF_ARCH_powerpc(ptext (sLit ".align ") <> int pow2,)))))
727 log2 :: Int -> Int -- cache the common ones
732 log2 n = 1 + log2 (n `quot` 2)
735 pprDataItem :: CmmLit -> Doc
737 = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit)
741 -- These seem to be common:
742 ppr_item II8 x = [ptext (sLit "\t.byte\t") <> pprImm imm]
743 ppr_item II32 x = [ptext (sLit "\t.long\t") <> pprImm imm]
744 ppr_item FF32 (CmmFloat r _)
745 = let bs = floatToBytes (fromRational r)
746 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
747 ppr_item FF64 (CmmFloat r _)
748 = let bs = doubleToBytes (fromRational r)
749 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
751 #if sparc_TARGET_ARCH
752 -- copy n paste of x86 version
753 ppr_item II16 x = [ptext (sLit "\t.short\t") <> pprImm imm]
754 ppr_item II64 x = [ptext (sLit "\t.quad\t") <> pprImm imm]
756 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
757 ppr_item II16 x = [ptext (sLit "\t.word\t") <> pprImm imm]
759 #if i386_TARGET_ARCH && darwin_TARGET_OS
760 ppr_item II64 (CmmInt x _) =
761 [ptext (sLit "\t.long\t")
762 <> int (fromIntegral (fromIntegral x :: Word32)),
763 ptext (sLit "\t.long\t")
765 (fromIntegral (x `shiftR` 32) :: Word32))]
767 #if i386_TARGET_ARCH || (darwin_TARGET_OS && x86_64_TARGET_ARCH)
768 ppr_item II64 x = [ptext (sLit "\t.quad\t") <> pprImm imm]
770 #if x86_64_TARGET_ARCH && !darwin_TARGET_OS
771 -- x86_64: binutils can't handle the R_X86_64_PC64 relocation
772 -- type, which means we can't do pc-relative 64-bit addresses.
773 -- Fortunately we're assuming the small memory model, in which
774 -- all such offsets will fit into 32 bits, so we have to stick
775 -- to 32-bit offset fields and modify the RTS appropriately
777 -- See Note [x86-64-relative] in includes/InfoTables.h
780 | isRelativeReloc x =
781 [ptext (sLit "\t.long\t") <> pprImm imm,
782 ptext (sLit "\t.long\t0")]
784 [ptext (sLit "\t.quad\t") <> pprImm imm]
786 isRelativeReloc (CmmLabelDiffOff _ _ _) = True
787 isRelativeReloc _ = False
789 #if powerpc_TARGET_ARCH
790 ppr_item II16 x = [ptext (sLit "\t.short\t") <> pprImm imm]
791 ppr_item II64 (CmmInt x _) =
792 [ptext (sLit "\t.long\t")
794 (fromIntegral (x `shiftR` 32) :: Word32)),
795 ptext (sLit "\t.long\t")
796 <> int (fromIntegral (fromIntegral x :: Word32))]
799 -- fall through to rest of (machine-specific) pprInstr...
801 -- -----------------------------------------------------------------------------
802 -- pprInstr: print an 'Instr'
804 instance Outputable Instr where
805 ppr instr = Outputable.docToSDoc $ pprInstr instr
807 pprInstr :: Instr -> Doc
809 --pprInstr (COMMENT s) = empty -- nuke 'em
811 = IF_ARCH_alpha( ((<>) (ptext (sLit "\t# ")) (ftext s))
812 ,IF_ARCH_sparc( ((<>) (ptext (sLit "! ")) (ftext s))
813 ,IF_ARCH_i386( ((<>) (ptext (sLit "# ")) (ftext s))
814 ,IF_ARCH_x86_64( ((<>) (ptext (sLit "# ")) (ftext s))
815 ,IF_ARCH_powerpc( IF_OS_linux(
816 ((<>) (ptext (sLit "# ")) (ftext s)),
817 ((<>) (ptext (sLit "; ")) (ftext s)))
821 = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
823 pprInstr (NEWBLOCK _)
824 = panic "PprMach.pprInstr: NEWBLOCK"
827 = panic "PprMach.pprInstr: LDATA"
829 -- -----------------------------------------------------------------------------
830 -- pprInstr for an Alpha
832 #if alpha_TARGET_ARCH
834 pprInstr (SPILL reg slot)
836 ptext (sLit "\tSPILL"),
840 ptext (sLit "SLOT") <> parens (int slot)]
842 pprInstr (RELOAD slot reg)
844 ptext (sLit "\tRELOAD"),
846 ptext (sLit "SLOT") <> parens (int slot),
850 pprInstr (LD size reg addr)
860 pprInstr (LDA reg addr)
862 ptext (sLit "\tlda\t"),
868 pprInstr (LDAH reg addr)
870 ptext (sLit "\tldah\t"),
876 pprInstr (LDGP reg addr)
878 ptext (sLit "\tldgp\t"),
884 pprInstr (LDI size reg imm)
886 ptext (sLit "\tldi"),
894 pprInstr (ST size reg addr)
906 ptext (sLit "\tclr\t"),
910 pprInstr (ABS size ri reg)
912 ptext (sLit "\tabs"),
920 pprInstr (NEG size ov ri reg)
922 ptext (sLit "\tneg"),
924 if ov then ptext (sLit "v\t") else char '\t',
930 pprInstr (ADD size ov reg1 ri reg2)
932 ptext (sLit "\tadd"),
934 if ov then ptext (sLit "v\t") else char '\t',
942 pprInstr (SADD size scale reg1 ri reg2)
944 ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
955 pprInstr (SUB size ov reg1 ri reg2)
957 ptext (sLit "\tsub"),
959 if ov then ptext (sLit "v\t") else char '\t',
967 pprInstr (SSUB size scale reg1 ri reg2)
969 ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
980 pprInstr (MUL size ov reg1 ri reg2)
982 ptext (sLit "\tmul"),
984 if ov then ptext (sLit "v\t") else char '\t',
992 pprInstr (DIV size uns reg1 ri reg2)
994 ptext (sLit "\tdiv"),
996 if uns then ptext (sLit "u\t") else char '\t',
1004 pprInstr (REM size uns reg1 ri reg2)
1006 ptext (sLit "\trem"),
1008 if uns then ptext (sLit "u\t") else char '\t',
1016 pprInstr (NOT ri reg)
1018 ptext (sLit "\tnot"),
1025 pprInstr (AND reg1 ri reg2) = pprRegRIReg (sLit "and") reg1 ri reg2
1026 pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg (sLit "andnot") reg1 ri reg2
1027 pprInstr (OR reg1 ri reg2) = pprRegRIReg (sLit "or") reg1 ri reg2
1028 pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg (sLit "ornot") reg1 ri reg2
1029 pprInstr (XOR reg1 ri reg2) = pprRegRIReg (sLit "xor") reg1 ri reg2
1030 pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg (sLit "xornot") reg1 ri reg2
1032 pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") reg1 ri reg2
1033 pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") reg1 ri reg2
1034 pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") reg1 ri reg2
1036 pprInstr (ZAP reg1 ri reg2) = pprRegRIReg (sLit "zap") reg1 ri reg2
1037 pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg (sLit "zapnot") reg1 ri reg2
1039 pprInstr (NOP) = ptext (sLit "\tnop")
1041 pprInstr (CMP cond reg1 ri reg2)
1043 ptext (sLit "\tcmp"),
1055 ptext (sLit "\tfclr\t"),
1059 pprInstr (FABS reg1 reg2)
1061 ptext (sLit "\tfabs\t"),
1067 pprInstr (FNEG size reg1 reg2)
1069 ptext (sLit "\tneg"),
1077 pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "add") size reg1 reg2 reg3
1078 pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "div") size reg1 reg2 reg3
1079 pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "mul") size reg1 reg2 reg3
1080 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "sub") size reg1 reg2 reg3
1082 pprInstr (CVTxy size1 size2 reg1 reg2)
1084 ptext (sLit "\tcvt"),
1086 case size2 of {Q -> ptext (sLit "qc"); _ -> pprSize size2},
1093 pprInstr (FCMP size cond reg1 reg2 reg3)
1095 ptext (sLit "\tcmp"),
1106 pprInstr (FMOV reg1 reg2)
1108 ptext (sLit "\tfmov\t"),
1114 pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
1116 pprInstr (BI NEVER reg lab) = empty
1118 pprInstr (BI cond reg lab)
1128 pprInstr (BF cond reg lab)
1130 ptext (sLit "\tfb"),
1139 = (<>) (ptext (sLit "\tbr\t")) (pprImm lab)
1141 pprInstr (JMP reg addr hint)
1143 ptext (sLit "\tjmp\t"),
1151 pprInstr (BSR imm n)
1152 = (<>) (ptext (sLit "\tbsr\t")) (pprImm imm)
1154 pprInstr (JSR reg addr n)
1156 ptext (sLit "\tjsr\t"),
1162 pprInstr (FUNBEGIN clab)
1164 if (externallyVisibleCLabel clab) then
1165 hcat [ptext (sLit "\t.globl\t"), pp_lab, char '\n']
1168 ptext (sLit "\t.ent "),
1177 pp_lab = pprCLabel_asm clab
1179 -- NEVER use commas within those string literals, cpp will ruin your day
1180 pp_ldgp = hcat [ ptext (sLit ":\n\tldgp $29"), char ',', ptext (sLit "0($27)\n") ]
1181 pp_frame = hcat [ ptext (sLit "..ng:\n\t.frame $30"), char ',',
1182 ptext (sLit "4240"), char ',',
1183 ptext (sLit "$26"), char ',',
1184 ptext (sLit "0\n\t.prologue 1") ]
1186 pprInstr (FUNEND clab)
1187 = (<>) (ptext (sLit "\t.align 4\n\t.end ")) (pprCLabel_asm clab)
1190 Continue with Alpha-only printing bits and bobs:
1194 pprRI (RIReg r) = pprReg r
1195 pprRI (RIImm r) = pprImm r
1197 pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
1198 pprRegRIReg name reg1 ri reg2
1210 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1211 pprSizeRegRegReg name size reg1 reg2 reg3
1224 #endif /* alpha_TARGET_ARCH */
1227 -- -----------------------------------------------------------------------------
1228 -- pprInstr for an x86
1230 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1232 pprInstr (SPILL reg slot)
1234 ptext (sLit "\tSPILL"),
1238 ptext (sLit "SLOT") <> parens (int slot)]
1240 pprInstr (RELOAD slot reg)
1242 ptext (sLit "\tRELOAD"),
1244 ptext (sLit "SLOT") <> parens (int slot),
1248 pprInstr (MOV size src dst)
1249 = pprSizeOpOp (sLit "mov") size src dst
1251 pprInstr (MOVZxL II32 src dst) = pprSizeOpOp (sLit "mov") II32 src dst
1252 -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple
1253 -- movl. But we represent it as a MOVZxL instruction, because
1254 -- the reg alloc would tend to throw away a plain reg-to-reg
1255 -- move, and we still want it to do that.
1257 pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce (sLit "movz") sizes II32 src dst
1258 -- zero-extension only needs to extend to 32 bits: on x86_64,
1259 -- the remaining zero-extension to 64 bits is automatic, and the 32-bit
1260 -- instruction is shorter.
1262 pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce (sLit "movs") sizes wordSize src dst
1264 -- here we do some patching, since the physical registers are only set late
1265 -- in the code generation.
1266 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1268 = pprSizeOpOp (sLit "add") size (OpReg reg2) dst
1269 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1271 = pprSizeOpOp (sLit "add") size (OpReg reg1) dst
1272 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))
1274 = pprInstr (ADD size (OpImm displ) dst)
1275 pprInstr (LEA size src dst) = pprSizeOpOp (sLit "lea") size src dst
1277 pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
1278 = pprSizeOp (sLit "dec") size dst
1279 pprInstr (ADD size (OpImm (ImmInt 1)) dst)
1280 = pprSizeOp (sLit "inc") size dst
1281 pprInstr (ADD size src dst)
1282 = pprSizeOpOp (sLit "add") size src dst
1283 pprInstr (ADC size src dst)
1284 = pprSizeOpOp (sLit "adc") size src dst
1285 pprInstr (SUB size src dst) = pprSizeOpOp (sLit "sub") size src dst
1286 pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2
1288 {- A hack. The Intel documentation says that "The two and three
1289 operand forms [of IMUL] may also be used with unsigned operands
1290 because the lower half of the product is the same regardless if
1291 (sic) the operands are signed or unsigned. The CF and OF flags,
1292 however, cannot be used to determine if the upper half of the
1293 result is non-zero." So there.
1295 pprInstr (AND size src dst) = pprSizeOpOp (sLit "and") size src dst
1296 pprInstr (OR size src dst) = pprSizeOpOp (sLit "or") size src dst
1298 pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst
1299 pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst
1300 pprInstr (XOR size src dst) = pprSizeOpOp (sLit "xor") size src dst
1302 pprInstr (NOT size op) = pprSizeOp (sLit "not") size op
1303 pprInstr (NEGI size op) = pprSizeOp (sLit "neg") size op
1305 pprInstr (SHL size src dst) = pprShift (sLit "shl") size src dst
1306 pprInstr (SAR size src dst) = pprShift (sLit "sar") size src dst
1307 pprInstr (SHR size src dst) = pprShift (sLit "shr") size src dst
1309 pprInstr (BT size imm src) = pprSizeImmOp (sLit "bt") size imm src
1311 pprInstr (CMP size src dst)
1312 | is_float size = pprSizeOpOp (sLit "ucomi") size src dst -- SSE2
1313 | otherwise = pprSizeOpOp (sLit "cmp") size src dst
1315 -- This predicate is needed here and nowhere else
1316 is_float FF32 = True
1317 is_float FF64 = True
1318 is_float FF80 = True
1319 is_float other = False
1321 pprInstr (TEST size src dst) = pprSizeOpOp (sLit "test") size src dst
1322 pprInstr (PUSH size op) = pprSizeOp (sLit "push") size op
1323 pprInstr (POP size op) = pprSizeOp (sLit "pop") size op
1325 -- both unused (SDM):
1326 -- pprInstr PUSHA = ptext (sLit "\tpushal")
1327 -- pprInstr POPA = ptext (sLit "\tpopal")
1329 pprInstr NOP = ptext (sLit "\tnop")
1330 pprInstr (CLTD II32) = ptext (sLit "\tcltd")
1331 pprInstr (CLTD II64) = ptext (sLit "\tcqto")
1333 pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op)
1335 pprInstr (JXX cond (BlockId id))
1336 = pprCondInstr (sLit "j") cond (pprCLabel_asm lab)
1337 where lab = mkAsmTempLabel id
1339 pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm)
1341 pprInstr (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm)
1342 pprInstr (JMP op) = (<>) (ptext (sLit "\tjmp *")) (pprOperand wordSize op)
1343 pprInstr (JMP_TBL op ids) = pprInstr (JMP op)
1344 pprInstr (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm)
1345 pprInstr (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg wordSize reg)
1347 pprInstr (IDIV sz op) = pprSizeOp (sLit "idiv") sz op
1348 pprInstr (DIV sz op) = pprSizeOp (sLit "div") sz op
1349 pprInstr (IMUL2 sz op) = pprSizeOp (sLit "imul") sz op
1351 #if x86_64_TARGET_ARCH
1352 pprInstr (MUL size op1 op2) = pprSizeOpOp (sLit "mul") size op1 op2
1354 pprInstr (FDIV size op1 op2) = pprSizeOpOp (sLit "div") size op1 op2
1356 pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to
1357 pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to
1358 pprInstr (CVTTSS2SIQ from to) = pprOpReg (sLit "cvttss2siq") from to
1359 pprInstr (CVTTSD2SIQ from to) = pprOpReg (sLit "cvttsd2siq") from to
1360 pprInstr (CVTSI2SS from to) = pprOpReg (sLit "cvtsi2ssq") from to
1361 pprInstr (CVTSI2SD from to) = pprOpReg (sLit "cvtsi2sdq") from to
1364 -- FETCHGOT for PIC on ELF platforms
1365 pprInstr (FETCHGOT reg)
1366 = vcat [ ptext (sLit "\tcall 1f"),
1367 hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ],
1368 hcat [ ptext (sLit "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "),
1372 -- FETCHPC for PIC on Darwin/x86
1373 -- get the instruction pointer into a register
1374 -- (Terminology note: the IP is called Program Counter on PPC,
1375 -- and it's a good thing to use the same name on both platforms)
1376 pprInstr (FETCHPC reg)
1377 = vcat [ ptext (sLit "\tcall 1f"),
1378 hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ]
1385 -- -----------------------------------------------------------------------------
1386 -- i386 floating-point
1388 #if i386_TARGET_ARCH
1389 -- Simulating a flat register set on the x86 FP stack is tricky.
1390 -- you have to free %st(7) before pushing anything on the FP reg stack
1391 -- so as to preclude the possibility of a FP stack overflow exception.
1392 pprInstr g@(GMOV src dst)
1396 = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
1398 -- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FSTP (dst+1)
1399 pprInstr g@(GLD sz addr dst)
1400 = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp,
1401 pprAddr addr, gsemi, gpop dst 1])
1403 -- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
1404 pprInstr g@(GST sz src addr)
1405 = pprG g (hcat [gtab, gpush src 0, gsemi,
1406 text "fstp", pprSize sz, gsp, pprAddr addr])
1408 pprInstr g@(GLDZ dst)
1409 = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1])
1410 pprInstr g@(GLD1 dst)
1411 = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1])
1413 pprInstr g@(GFTOI src dst)
1414 = pprInstr (GDTOI src dst)
1415 pprInstr g@(GDTOI src dst)
1417 hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"],
1418 hcat [gtab, gpush src 0],
1419 hcat [gtab, text "movzwl 4(%esp), ", reg,
1420 text " ; orl $0xC00, ", reg],
1421 hcat [gtab, text "movl ", reg, text ", 0(%esp) ; fldcw 0(%esp)"],
1422 hcat [gtab, text "fistpl 0(%esp)"],
1423 hcat [gtab, text "fldcw 4(%esp) ; movl 0(%esp), ", reg],
1424 hcat [gtab, text "addl $8, %esp"]
1427 reg = pprReg II32 dst
1429 pprInstr g@(GITOF src dst)
1430 = pprInstr (GITOD src dst)
1431 pprInstr g@(GITOD src dst)
1432 = pprG g (hcat [gtab, text "pushl ", pprReg II32 src,
1433 text " ; ffree %st(7); fildl (%esp) ; ",
1434 gpop dst 1, text " ; addl $4,%esp"])
1436 {- Gruesome swamp follows. If you're unfortunate enough to have ventured
1437 this far into the jungle AND you give a Rat's Ass (tm) what's going
1438 on, here's the deal. Generate code to do a floating point comparison
1439 of src1 and src2, of kind cond, and set the Zero flag if true.
1441 The complications are to do with handling NaNs correctly. We want the
1442 property that if either argument is NaN, then the result of the
1443 comparison is False ... except if we're comparing for inequality,
1444 in which case the answer is True.
1446 Here's how the general (non-inequality) case works. As an
1447 example, consider generating the an equality test:
1449 pushl %eax -- we need to mess with this
1450 <get src1 to top of FPU stack>
1451 fcomp <src2 location in FPU stack> and pop pushed src1
1452 -- Result of comparison is in FPU Status Register bits
1454 fstsw %ax -- Move FPU Status Reg to %ax
1455 sahf -- move C3 C2 C0 from %ax to integer flag reg
1456 -- now the serious magic begins
1457 setpo %ah -- %ah = if comparable(neither arg was NaN) then 1 else 0
1458 sete %al -- %al = if arg1 == arg2 then 1 else 0
1459 andb %ah,%al -- %al &= %ah
1460 -- so %al == 1 iff (comparable && same); else it holds 0
1461 decb %al -- %al == 0, ZeroFlag=1 iff (comparable && same);
1462 else %al == 0xFF, ZeroFlag=0
1463 -- the zero flag is now set as we desire.
1466 The special case of inequality differs thusly:
1468 setpe %ah -- %ah = if incomparable(either arg was NaN) then 1 else 0
1469 setne %al -- %al = if arg1 /= arg2 then 1 else 0
1470 orb %ah,%al -- %al = if (incomparable || different) then 1 else 0
1471 decb %al -- if (incomparable || different) then (%al == 0, ZF=1)
1472 else (%al == 0xFF, ZF=0)
1474 pprInstr g@(GCMP cond src1 src2)
1475 | case cond of { NE -> True; other -> False }
1477 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1478 hcat [gtab, text "fcomp ", greg src2 1,
1479 text "; fstsw %ax ; sahf ; setpe %ah"],
1480 hcat [gtab, text "setne %al ; ",
1481 text "orb %ah,%al ; decb %al ; popl %eax"]
1485 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1486 hcat [gtab, text "fcomp ", greg src2 1,
1487 text "; fstsw %ax ; sahf ; setpo %ah"],
1488 hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ; ",
1489 text "andb %ah,%al ; decb %al ; popl %eax"]
1492 {- On the 486, the flags set by FP compare are the unsigned ones!
1493 (This looks like a HACK to me. WDP 96/03)
1495 fix_FP_cond :: Cond -> Cond
1496 fix_FP_cond GE = GEU
1497 fix_FP_cond GTT = GU
1498 fix_FP_cond LTT = LU
1499 fix_FP_cond LE = LEU
1500 fix_FP_cond EQQ = EQQ
1502 -- there should be no others
1505 pprInstr g@(GABS sz src dst)
1506 = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
1507 pprInstr g@(GNEG sz src dst)
1508 = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
1510 pprInstr g@(GSQRT sz src dst)
1511 = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
1512 hcat [gtab, gcoerceto sz, gpop dst 1])
1513 pprInstr g@(GSIN sz l1 l2 src dst)
1514 = pprG g (pprTrigOp "fsin" False l1 l2 src dst sz)
1515 pprInstr g@(GCOS sz l1 l2 src dst)
1516 = pprG g (pprTrigOp "fcos" False l1 l2 src dst sz)
1517 pprInstr g@(GTAN sz l1 l2 src dst)
1518 = pprG g (pprTrigOp "fptan" True l1 l2 src dst sz)
1520 -- In the translations for GADD, GMUL, GSUB and GDIV,
1521 -- the first two cases are mere optimisations. The otherwise clause
1522 -- generates correct code under all circumstances.
1524 pprInstr g@(GADD sz src1 src2 dst)
1526 = pprG g (text "\t#GADD-xxxcase1" $$
1527 hcat [gtab, gpush src2 0,
1528 text " ; faddp %st(0),", greg src1 1])
1530 = pprG g (text "\t#GADD-xxxcase2" $$
1531 hcat [gtab, gpush src1 0,
1532 text " ; faddp %st(0),", greg src2 1])
1534 = pprG g (hcat [gtab, gpush src1 0,
1535 text " ; fadd ", greg src2 1, text ",%st(0)",
1539 pprInstr g@(GMUL sz src1 src2 dst)
1541 = pprG g (text "\t#GMUL-xxxcase1" $$
1542 hcat [gtab, gpush src2 0,
1543 text " ; fmulp %st(0),", greg src1 1])
1545 = pprG g (text "\t#GMUL-xxxcase2" $$
1546 hcat [gtab, gpush src1 0,
1547 text " ; fmulp %st(0),", greg src2 1])
1549 = pprG g (hcat [gtab, gpush src1 0,
1550 text " ; fmul ", greg src2 1, text ",%st(0)",
1554 pprInstr g@(GSUB sz src1 src2 dst)
1556 = pprG g (text "\t#GSUB-xxxcase1" $$
1557 hcat [gtab, gpush src2 0,
1558 text " ; fsubrp %st(0),", greg src1 1])
1560 = pprG g (text "\t#GSUB-xxxcase2" $$
1561 hcat [gtab, gpush src1 0,
1562 text " ; fsubp %st(0),", greg src2 1])
1564 = pprG g (hcat [gtab, gpush src1 0,
1565 text " ; fsub ", greg src2 1, text ",%st(0)",
1569 pprInstr g@(GDIV sz src1 src2 dst)
1571 = pprG g (text "\t#GDIV-xxxcase1" $$
1572 hcat [gtab, gpush src2 0,
1573 text " ; fdivrp %st(0),", greg src1 1])
1575 = pprG g (text "\t#GDIV-xxxcase2" $$
1576 hcat [gtab, gpush src1 0,
1577 text " ; fdivp %st(0),", greg src2 1])
1579 = pprG g (hcat [gtab, gpush src1 0,
1580 text " ; fdiv ", greg src2 1, text ",%st(0)",
1585 = vcat [ ptext (sLit "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
1586 ptext (sLit "\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)")
1589 pprTrigOp :: String -> Bool -> CLabel -> CLabel -> Reg -> Reg -> Size -> Doc
1590 pprTrigOp op -- fsin, fcos or fptan
1591 isTan -- we need a couple of extra steps if we're doing tan
1592 l1 l2 -- internal labels for us to use
1594 = -- We'll be needing %eax later on
1595 hcat [gtab, text "pushl %eax;"] $$
1596 -- tan is going to use an extra space on the FP stack
1597 (if isTan then hcat [gtab, text "ffree %st(6)"] else empty) $$
1598 -- First put the value in %st(0) and try to apply the op to it
1599 hcat [gpush src 0, text ("; " ++ op)] $$
1600 -- Now look to see if C2 was set (overflow, |value| >= 2^63)
1601 hcat [gtab, text "fnstsw %ax"] $$
1602 hcat [gtab, text "test $0x400,%eax"] $$
1603 -- If we were in bounds then jump to the end
1604 hcat [gtab, text "je " <> pprCLabel_asm l1] $$
1605 -- Otherwise we need to shrink the value. Start by
1606 -- loading pi, doubleing it (by adding it to itself),
1607 -- and then swapping pi with the value, so the value we
1608 -- want to apply op to is in %st(0) again
1609 hcat [gtab, text "ffree %st(7); fldpi"] $$
1610 hcat [gtab, text "fadd %st(0),%st"] $$
1611 hcat [gtab, text "fxch %st(1)"] $$
1612 -- Now we have a loop in which we make the value smaller,
1613 -- see if it's small enough, and loop if not
1614 (pprCLabel_asm l2 <> char ':') $$
1615 hcat [gtab, text "fprem1"] $$
1616 -- My Debian libc uses fstsw here for the tan code, but I can't
1617 -- see any reason why it should need to be different for tan.
1618 hcat [gtab, text "fnstsw %ax"] $$
1619 hcat [gtab, text "test $0x400,%eax"] $$
1620 hcat [gtab, text "jne " <> pprCLabel_asm l2] $$
1621 hcat [gtab, text "fstp %st(1)"] $$
1622 hcat [gtab, text op] $$
1623 (pprCLabel_asm l1 <> char ':') $$
1624 -- Pop the 1.0 tan gave us
1625 (if isTan then hcat [gtab, text "fstp %st(0)"] else empty) $$
1627 hcat [gtab, text "popl %eax;"] $$
1628 -- And finally make the result the right size
1629 hcat [gtab, gcoerceto sz, gpop dst 1]
1631 --------------------------
1633 -- coerce %st(0) to the specified size
1634 gcoerceto FF64 = empty
1635 gcoerceto FF32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
1638 = hcat [text "ffree %st(7) ; fld ", greg reg offset]
1640 = hcat [text "fstp ", greg reg offset]
1642 greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
1647 gregno (RealReg i) = i
1648 gregno other = --pprPanic "gregno" (ppr other)
1649 999 -- bogus; only needed for debug printing
1651 pprG :: Instr -> Doc -> Doc
1653 = (char '#' <> pprGInstr fake) $$ actual
1655 pprGInstr (GMOV src dst) = pprSizeRegReg (sLit "gmov") FF64 src dst
1656 pprGInstr (GLD sz src dst) = pprSizeAddrReg (sLit "gld") sz src dst
1657 pprGInstr (GST sz src dst) = pprSizeRegAddr (sLit "gst") sz src dst
1659 pprGInstr (GLDZ dst) = pprSizeReg (sLit "gldz") FF64 dst
1660 pprGInstr (GLD1 dst) = pprSizeReg (sLit "gld1") FF64 dst
1662 pprGInstr (GFTOI src dst) = pprSizeSizeRegReg (sLit "gftoi") FF32 II32 src dst
1663 pprGInstr (GDTOI src dst) = pprSizeSizeRegReg (sLit "gdtoi") FF64 II32 src dst
1665 pprGInstr (GITOF src dst) = pprSizeSizeRegReg (sLit "gitof") II32 FF32 src dst
1666 pprGInstr (GITOD src dst) = pprSizeSizeRegReg (sLit "gitod") II32 FF64 src dst
1668 pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 co src dst
1669 pprGInstr (GABS sz src dst) = pprSizeRegReg (sLit "gabs") sz src dst
1670 pprGInstr (GNEG sz src dst) = pprSizeRegReg (sLit "gneg") sz src dst
1671 pprGInstr (GSQRT sz src dst) = pprSizeRegReg (sLit "gsqrt") sz src dst
1672 pprGInstr (GSIN sz _ _ src dst) = pprSizeRegReg (sLit "gsin") sz src dst
1673 pprGInstr (GCOS sz _ _ src dst) = pprSizeRegReg (sLit "gcos") sz src dst
1674 pprGInstr (GTAN sz _ _ src dst) = pprSizeRegReg (sLit "gtan") sz src dst
1676 pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg (sLit "gadd") sz src1 src2 dst
1677 pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg (sLit "gsub") sz src1 src2 dst
1678 pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg (sLit "gmul") sz src1 src2 dst
1679 pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg (sLit "gdiv") sz src1 src2 dst
1682 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1684 -- Continue with I386-only printing bits and bobs:
1686 pprDollImm :: Imm -> Doc
1688 pprDollImm i = ptext (sLit "$") <> pprImm i
1690 pprOperand :: Size -> Operand -> Doc
1691 pprOperand s (OpReg r) = pprReg s r
1692 pprOperand s (OpImm i) = pprDollImm i
1693 pprOperand s (OpAddr ea) = pprAddr ea
1695 pprMnemonic_ :: LitString -> Doc
1697 char '\t' <> ptext name <> space
1699 pprMnemonic :: LitString -> Size -> Doc
1700 pprMnemonic name size =
1701 char '\t' <> ptext name <> pprSize size <> space
1703 pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc
1704 pprSizeImmOp name size imm op1
1706 pprMnemonic name size,
1713 pprSizeOp :: LitString -> Size -> Operand -> Doc
1714 pprSizeOp name size op1
1716 pprMnemonic name size,
1720 pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1721 pprSizeOpOp name size op1 op2
1723 pprMnemonic name size,
1724 pprOperand size op1,
1729 pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1730 pprOpOp name size op1 op2
1733 pprOperand size op1,
1738 pprSizeReg :: LitString -> Size -> Reg -> Doc
1739 pprSizeReg name size reg1
1741 pprMnemonic name size,
1745 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
1746 pprSizeRegReg name size reg1 reg2
1748 pprMnemonic name size,
1754 pprRegReg :: LitString -> Reg -> Reg -> Doc
1755 pprRegReg name reg1 reg2
1758 pprReg wordSize reg1,
1760 pprReg wordSize reg2
1763 pprOpReg :: LitString -> Operand -> Reg -> Doc
1764 pprOpReg name op1 reg2
1767 pprOperand wordSize op1,
1769 pprReg wordSize reg2
1772 pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc
1773 pprCondRegReg name size cond reg1 reg2
1784 pprSizeSizeRegReg :: LitString -> Size -> Size -> Reg -> Reg -> Doc
1785 pprSizeSizeRegReg name size1 size2 reg1 reg2
1798 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1799 pprSizeRegRegReg name size reg1 reg2 reg3
1801 pprMnemonic name size,
1809 pprSizeAddrReg :: LitString -> Size -> AddrMode -> Reg -> Doc
1810 pprSizeAddrReg name size op dst
1812 pprMnemonic name size,
1818 pprSizeRegAddr :: LitString -> Size -> Reg -> AddrMode -> Doc
1819 pprSizeRegAddr name size src op
1821 pprMnemonic name size,
1827 pprShift :: LitString -> Size -> Operand -> Operand -> Doc
1828 pprShift name size src dest
1830 pprMnemonic name size,
1831 pprOperand II8 src, -- src is 8-bit sized
1833 pprOperand size dest
1836 pprSizeOpOpCoerce :: LitString -> Size -> Size -> Operand -> Operand -> Doc
1837 pprSizeOpOpCoerce name size1 size2 op1 op2
1838 = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
1839 pprOperand size1 op1,
1841 pprOperand size2 op2
1844 pprCondInstr :: LitString -> Cond -> Doc -> Doc
1845 pprCondInstr name cond arg
1846 = hcat [ char '\t', ptext name, pprCond cond, space, arg]
1848 #endif /* i386_TARGET_ARCH */
1851 -- ------------------------------------------------------------------------------- pprInstr for a SPARC
1853 #if sparc_TARGET_ARCH
1855 -- a clumsy hack for now, to handle possible double alignment problems
1857 -- even clumsier, to allow for RegReg regs that show when doing indexed
1858 -- reads (bytearrays).
1861 pprInstr (SPILL reg slot)
1863 ptext (sLit "\tSPILL"),
1867 ptext (sLit "SLOT") <> parens (int slot)]
1869 pprInstr (RELOAD slot reg)
1871 ptext (sLit "\tRELOAD"),
1873 ptext (sLit "SLOT") <> parens (int slot),
1877 -- Translate to the following:
1880 -- ld [g1+4],%f(n+1)
1881 -- sub g1,g2,g1 -- to restore g1
1883 pprInstr (LD FF64 (AddrRegReg g1 g2) reg)
1885 hcat [ptext (sLit "\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1886 hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg],
1887 hcat [pp_ld_lbracket, pprReg g1, ptext (sLit "+4]"), comma, pprReg (fPair reg)],
1888 hcat [ptext (sLit "\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1893 -- ld [addr+4],%f(n+1)
1894 pprInstr (LD FF64 addr reg) | isJust off_addr
1896 hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
1897 hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg (fPair reg)]
1900 off_addr = addrOffset addr 4
1901 addr2 = case off_addr of Just x -> x
1904 pprInstr (LD size addr reg)
1906 ptext (sLit "\tld"),
1915 -- The same clumsy hack as above
1917 -- Translate to the following:
1920 -- st %f(n+1),[g1+4]
1921 -- sub g1,g2,g1 -- to restore g1
1922 pprInstr (ST FF64 reg (AddrRegReg g1 g2))
1924 hcat [ptext (sLit "\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1925 hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket,
1927 hcat [ptext (sLit "\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1928 pprReg g1, ptext (sLit "+4]")],
1929 hcat [ptext (sLit "\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1934 -- st %f(n+1),[addr+4]
1935 pprInstr (ST FF64 reg addr) | isJust off_addr
1937 hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket,
1938 pprAddr addr, rbrack],
1939 hcat [ptext (sLit "\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1940 pprAddr addr2, rbrack]
1943 off_addr = addrOffset addr 4
1944 addr2 = case off_addr of Just x -> x
1946 -- no distinction is made between signed and unsigned bytes on stores for the
1947 -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
1948 -- so we call a special-purpose pprSize for ST..
1950 pprInstr (ST size reg addr)
1952 ptext (sLit "\tst"),
1961 pprInstr (ADD x cc reg1 ri reg2)
1962 | not x && not cc && riZero ri
1963 = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1965 = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2
1967 pprInstr (SUB x cc reg1 ri reg2)
1968 | not x && cc && reg2 == g0
1969 = hcat [ ptext (sLit "\tcmp\t"), pprReg reg1, comma, pprRI ri ]
1970 | not x && not cc && riZero ri
1971 = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1973 = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2
1975 pprInstr (AND b reg1 ri reg2) = pprRegRIReg (sLit "and") b reg1 ri reg2
1976 pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2
1978 pprInstr (OR b reg1 ri reg2)
1979 | not b && reg1 == g0
1980 = let doit = hcat [ ptext (sLit "\tmov\t"), pprRI ri, comma, pprReg reg2 ]
1982 RIReg rrr | rrr == reg2 -> empty
1985 = pprRegRIReg (sLit "or") b reg1 ri reg2
1987 pprInstr (ORN b reg1 ri reg2) = pprRegRIReg (sLit "orn") b reg1 ri reg2
1989 pprInstr (XOR b reg1 ri reg2) = pprRegRIReg (sLit "xor") b reg1 ri reg2
1990 pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg (sLit "xnor") b reg1 ri reg2
1992 pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") False reg1 ri reg2
1993 pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") False reg1 ri reg2
1994 pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") False reg1 ri reg2
1996 pprInstr (RDY rd) = ptext (sLit "\trd\t%y,") <> pprReg rd
1997 pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul") b reg1 ri reg2
1998 pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul") b reg1 ri reg2
2000 pprInstr (SETHI imm reg)
2002 ptext (sLit "\tsethi\t"),
2008 pprInstr NOP = ptext (sLit "\tnop")
2010 pprInstr (FABS FF32 reg1 reg2) = pprSizeRegReg (sLit "fabs") FF32 reg1 reg2
2011 pprInstr (FABS FF64 reg1 reg2)
2012 = (<>) (pprSizeRegReg (sLit "fabs") FF32 reg1 reg2)
2013 (if (reg1 == reg2) then empty
2014 else (<>) (char '\n')
2015 (pprSizeRegReg (sLit "fmov") FF32 (fPair reg1) (fPair reg2)))
2017 pprInstr (FADD size reg1 reg2 reg3)
2018 = pprSizeRegRegReg (sLit "fadd") size reg1 reg2 reg3
2019 pprInstr (FCMP e size reg1 reg2)
2020 = pprSizeRegReg (if e then sLit "fcmpe" else sLit "fcmp") size reg1 reg2
2021 pprInstr (FDIV size reg1 reg2 reg3)
2022 = pprSizeRegRegReg (sLit "fdiv") size reg1 reg2 reg3
2024 pprInstr (FMOV FF32 reg1 reg2) = pprSizeRegReg (sLit "fmov") FF32 reg1 reg2
2025 pprInstr (FMOV FF64 reg1 reg2)
2026 = (<>) (pprSizeRegReg (sLit "fmov") FF32 reg1 reg2)
2027 (if (reg1 == reg2) then empty
2028 else (<>) (char '\n')
2029 (pprSizeRegReg (sLit "fmov") FF32 (fPair reg1) (fPair reg2)))
2031 pprInstr (FMUL size reg1 reg2 reg3)
2032 = pprSizeRegRegReg (sLit "fmul") size reg1 reg2 reg3
2034 pprInstr (FNEG FF32 reg1 reg2) = pprSizeRegReg (sLit "fneg") FF32 reg1 reg2
2035 pprInstr (FNEG FF64 reg1 reg2)
2036 = (<>) (pprSizeRegReg (sLit "fneg") FF32 reg1 reg2)
2037 (if (reg1 == reg2) then empty
2038 else (<>) (char '\n')
2039 (pprSizeRegReg (sLit "fmov") FF32 (fPair reg1) (fPair reg2)))
2041 pprInstr (FSQRT size reg1 reg2) = pprSizeRegReg (sLit "fsqrt") size reg1 reg2
2042 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fsub") size reg1 reg2 reg3
2043 pprInstr (FxTOy size1 size2 reg1 reg2)
2050 FF64 -> sLit "dto"),
2055 FF64 -> sLit "d\t"),
2056 pprReg reg1, comma, pprReg reg2
2060 pprInstr (BI cond b lab)
2062 ptext (sLit "\tb"), pprCond cond,
2063 if b then pp_comma_a else empty,
2068 pprInstr (BF cond b lab)
2070 ptext (sLit "\tfb"), pprCond cond,
2071 if b then pp_comma_a else empty,
2076 pprInstr (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr addr)
2078 pprInstr (CALL (Left imm) n _)
2079 = hcat [ ptext (sLit "\tcall\t"), pprImm imm, comma, int n ]
2080 pprInstr (CALL (Right reg) n _)
2081 = hcat [ ptext (sLit "\tcall\t"), pprReg reg, comma, int n ]
2084 pprRI (RIReg r) = pprReg r
2085 pprRI (RIImm r) = pprImm r
2087 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
2088 pprSizeRegReg name size reg1 reg2
2093 FF32 -> ptext (sLit "s\t")
2094 FF64 -> ptext (sLit "d\t")),
2100 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
2101 pprSizeRegRegReg name size reg1 reg2 reg3
2106 FF32 -> ptext (sLit "s\t")
2107 FF64 -> ptext (sLit "d\t")),
2115 pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
2116 pprRegRIReg name b reg1 ri reg2
2120 if b then ptext (sLit "cc\t") else char '\t',
2128 pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
2129 pprRIReg name b ri reg1
2133 if b then ptext (sLit "cc\t") else char '\t',
2139 pp_ld_lbracket = ptext (sLit "\tld\t[")
2140 pp_rbracket_comma = text "],"
2141 pp_comma_lbracket = text ",["
2142 pp_comma_a = text ",a"
2144 #endif /* sparc_TARGET_ARCH */
2147 -- -----------------------------------------------------------------------------
2148 -- pprInstr for PowerPC
2150 #if powerpc_TARGET_ARCH
2152 pprInstr (SPILL reg slot)
2154 ptext (sLit "\tSPILL"),
2158 ptext (sLit "SLOT") <> parens (int slot)]
2160 pprInstr (RELOAD slot reg)
2162 ptext (sLit "\tRELOAD"),
2164 ptext (sLit "SLOT") <> parens (int slot),
2168 pprInstr (LD sz reg addr) = hcat [
2177 case addr of AddrRegImm _ _ -> empty
2178 AddrRegReg _ _ -> char 'x',
2184 pprInstr (LA sz reg addr) = hcat [
2193 case addr of AddrRegImm _ _ -> empty
2194 AddrRegReg _ _ -> char 'x',
2200 pprInstr (ST sz reg addr) = hcat [
2204 case addr of AddrRegImm _ _ -> empty
2205 AddrRegReg _ _ -> char 'x',
2211 pprInstr (STU sz reg addr) = hcat [
2216 case addr of AddrRegImm _ _ -> empty
2217 AddrRegReg _ _ -> char 'x',
2222 pprInstr (LIS reg imm) = hcat [
2230 pprInstr (LI reg imm) = hcat [
2238 pprInstr (MR reg1 reg2)
2239 | reg1 == reg2 = empty
2240 | otherwise = hcat [
2242 case regClass reg1 of
2243 RcInteger -> ptext (sLit "mr")
2244 _ -> ptext (sLit "fmr"),
2250 pprInstr (CMP sz reg ri) = hcat [
2266 pprInstr (CMPL sz reg ri) = hcat [
2276 ptext (sLit "cmpl"),
2282 pprInstr (BCC cond (BlockId id)) = hcat [
2289 where lbl = mkAsmTempLabel id
2291 pprInstr (BCCFAR cond (BlockId id)) = vcat [
2294 pprCond (condNegate cond),
2295 ptext (sLit "\t$+8")
2298 ptext (sLit "\tb\t"),
2302 where lbl = mkAsmTempLabel id
2304 pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
2311 pprInstr (MTCTR reg) = hcat [
2313 ptext (sLit "mtctr"),
2317 pprInstr (BCTR _) = hcat [
2321 pprInstr (BL lbl _) = hcat [
2322 ptext (sLit "\tbl\t"),
2325 pprInstr (BCTRL _) = hcat [
2327 ptext (sLit "bctrl")
2329 pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri
2330 pprInstr (ADDIS reg1 reg2 imm) = hcat [
2332 ptext (sLit "addis"),
2341 pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3)
2342 pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3)
2343 pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3)
2344 pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri
2345 pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri
2346 pprInstr (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3)
2347 pprInstr (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3)
2349 pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
2350 hcat [ ptext (sLit "\tmullwo\t"), pprReg reg1, ptext (sLit ", "),
2351 pprReg reg2, ptext (sLit ", "),
2353 hcat [ ptext (sLit "\tmfxer\t"), pprReg reg1 ],
2354 hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "),
2355 pprReg reg1, ptext (sLit ", "),
2356 ptext (sLit "2, 31, 31") ]
2359 -- for some reason, "andi" doesn't exist.
2360 -- we'll use "andi." instead.
2361 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
2363 ptext (sLit "andi."),
2371 pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri
2373 pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri
2374 pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri
2376 pprInstr (XORIS reg1 reg2 imm) = hcat [
2378 ptext (sLit "xoris"),
2387 pprInstr (EXTS sz reg1 reg2) = hcat [
2389 ptext (sLit "exts"),
2397 pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2
2398 pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2
2400 pprInstr (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri)
2401 pprInstr (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri)
2402 pprInstr (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri)
2403 pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
2404 ptext (sLit "\trlwinm\t"),
2416 pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF (sLit "fadd") sz reg1 reg2 reg3
2417 pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF (sLit "fsub") sz reg1 reg2 reg3
2418 pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF (sLit "fmul") sz reg1 reg2 reg3
2419 pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") sz reg1 reg2 reg3
2420 pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2
2422 pprInstr (FCMP reg1 reg2) = hcat [
2424 ptext (sLit "fcmpu\tcr0, "),
2425 -- Note: we're using fcmpu, not fcmpo
2426 -- The difference is with fcmpo, compare with NaN is an invalid operation.
2427 -- We don't handle invalid fp ops, so we don't care
2433 pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2
2434 pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2
2436 pprInstr (CRNOR dst src1 src2) = hcat [
2437 ptext (sLit "\tcrnor\t"),
2445 pprInstr (MFCR reg) = hcat [
2447 ptext (sLit "mfcr"),
2452 pprInstr (MFLR reg) = hcat [
2454 ptext (sLit "mflr"),
2459 pprInstr (FETCHPC reg) = vcat [
2460 ptext (sLit "\tbcl\t20,31,1f"),
2461 hcat [ ptext (sLit "1:\tmflr\t"), pprReg reg ]
2464 pprInstr LWSYNC = ptext (sLit "\tlwsync")
2466 pprInstr _ = panic "pprInstr (ppc)"
2468 pprLogic op reg1 reg2 ri = hcat [
2473 RIImm _ -> char 'i',
2482 pprUnary op reg1 reg2 = hcat [
2491 pprBinaryF op sz reg1 reg2 reg3 = hcat [
2504 pprRI (RIReg r) = pprReg r
2505 pprRI (RIImm r) = pprImm r
2507 pprFSize FF64 = empty
2508 pprFSize FF32 = char 's'
2510 -- limit immediate argument for shift instruction to range 0..32
2511 -- (yes, the maximum is really 32, not 31)
2512 limitShiftRI :: RI -> RI
2513 limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32)
2516 #endif /* powerpc_TARGET_ARCH */
2519 -- -----------------------------------------------------------------------------
2520 -- Converting floating-point literals to integrals for printing
2522 castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)
2523 castFloatToWord8Array = castSTUArray
2525 castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8)
2526 castDoubleToWord8Array = castSTUArray
2528 -- floatToBytes and doubleToBytes convert to the host's byte
2529 -- order. Providing that we're not cross-compiling for a
2530 -- target with the opposite endianness, this should work ok
2533 -- ToDo: this stuff is very similar to the shenanigans in PprAbs,
2534 -- could they be merged?
2536 floatToBytes :: Float -> [Int]
2539 arr <- newArray_ ((0::Int),3)
2541 arr <- castFloatToWord8Array arr
2542 i0 <- readArray arr 0
2543 i1 <- readArray arr 1
2544 i2 <- readArray arr 2
2545 i3 <- readArray arr 3
2546 return (map fromIntegral [i0,i1,i2,i3])
2549 doubleToBytes :: Double -> [Int]
2552 arr <- newArray_ ((0::Int),7)
2554 arr <- castDoubleToWord8Array arr
2555 i0 <- readArray arr 0
2556 i1 <- readArray arr 1
2557 i2 <- readArray arr 2
2558 i3 <- readArray arr 3
2559 i4 <- readArray arr 4
2560 i5 <- readArray arr 5
2561 i6 <- readArray arr 6
2562 i7 <- readArray arr 7
2563 return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7])