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 MachOp ( MachRep(..), wordRep, isFloatingRep )
32 import MachRegs -- may differ per-platform
35 import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel,
36 labelDynamic, mkAsmTempLabel, entryLblToInfoLbl )
37 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
38 import CLabel ( mkDeadStripPreventer )
41 import Panic ( panic )
42 import Unique ( pprUnique )
45 import qualified Outputable
46 import Outputable ( Outputable )
49 import Data.Word ( Word8 )
50 import Control.Monad.ST
51 import Data.Char ( chr, ord )
52 import Data.Maybe ( isJust )
54 #if powerpc_TARGET_ARCH || darwin_TARGET_OS
55 import Data.Word(Word32)
59 -- -----------------------------------------------------------------------------
60 -- Printing this stuff out
62 asmSDoc d = Outputable.withPprStyleDoc (
63 Outputable.mkCodeStyle Outputable.AsmStyle) d
64 pprCLabel_asm l = asmSDoc (pprCLabel l)
66 pprNatCmmTop :: NatCmmTop -> Doc
67 pprNatCmmTop (CmmData section dats) =
68 pprSectionHeader section $$ vcat (map pprData dats)
70 -- special case for split markers:
71 pprNatCmmTop (CmmProc [] lbl _ (ListGraph [])) = pprLabel lbl
73 pprNatCmmTop (CmmProc info lbl params (ListGraph blocks)) =
74 pprSectionHeader Text $$
75 (if null info then -- blocks guaranteed not null, so label needed
78 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
79 pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
82 vcat (map pprData info) $$
83 pprLabel (entryLblToInfoLbl lbl)
85 vcat (map pprBasicBlock blocks)
86 -- above: Even the first block gets a label, because with branch-chain
87 -- elimination, it might be the target of a goto.
88 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
89 -- If we are using the .subsections_via_symbols directive
90 -- (available on recent versions of Darwin),
91 -- we have to make sure that there is some kind of reference
92 -- from the entry code to a label on the _top_ of of the info table,
93 -- so that the linker will not think it is unreferenced and dead-strip
94 -- it. That's why the label is called a DeadStripPreventer (_dsp).
97 <+> pprCLabel_asm (entryLblToInfoLbl lbl)
99 <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
104 pprBasicBlock :: NatBasicBlock -> Doc
105 pprBasicBlock (BasicBlock (BlockId id) instrs) =
106 pprLabel (mkAsmTempLabel id) $$
107 vcat (map pprInstr instrs)
109 -- -----------------------------------------------------------------------------
110 -- pprReg: print a 'Reg'
112 -- For x86, the way we print a register name depends
113 -- on which bit of it we care about. Yurgh.
115 pprUserReg :: Reg -> Doc
116 pprUserReg = pprReg IF_ARCH_i386(I32,) IF_ARCH_x86_64(I64,)
118 pprReg :: IF_ARCH_i386(MachRep ->,) IF_ARCH_x86_64(MachRep ->,) Reg -> Doc
120 pprReg IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) r
122 RealReg i -> ppr_reg_no IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) i
123 VirtualRegI u -> text "%vI_" <> asmSDoc (pprUnique u)
124 VirtualRegHi u -> text "%vHi_" <> asmSDoc (pprUnique u)
125 VirtualRegF u -> text "%vF_" <> asmSDoc (pprUnique u)
126 VirtualRegD u -> text "%vD_" <> asmSDoc (pprUnique u)
128 #if alpha_TARGET_ARCH
129 ppr_reg_no :: Int -> Doc
132 0 -> sLit "$0"; 1 -> sLit "$1";
133 2 -> sLit "$2"; 3 -> sLit "$3";
134 4 -> sLit "$4"; 5 -> sLit "$5";
135 6 -> sLit "$6"; 7 -> sLit "$7";
136 8 -> sLit "$8"; 9 -> sLit "$9";
137 10 -> sLit "$10"; 11 -> sLit "$11";
138 12 -> sLit "$12"; 13 -> sLit "$13";
139 14 -> sLit "$14"; 15 -> sLit "$15";
140 16 -> sLit "$16"; 17 -> sLit "$17";
141 18 -> sLit "$18"; 19 -> sLit "$19";
142 20 -> sLit "$20"; 21 -> sLit "$21";
143 22 -> sLit "$22"; 23 -> sLit "$23";
144 24 -> sLit "$24"; 25 -> sLit "$25";
145 26 -> sLit "$26"; 27 -> sLit "$27";
146 28 -> sLit "$28"; 29 -> sLit "$29";
147 30 -> sLit "$30"; 31 -> sLit "$31";
148 32 -> sLit "$f0"; 33 -> sLit "$f1";
149 34 -> sLit "$f2"; 35 -> sLit "$f3";
150 36 -> sLit "$f4"; 37 -> sLit "$f5";
151 38 -> sLit "$f6"; 39 -> sLit "$f7";
152 40 -> sLit "$f8"; 41 -> sLit "$f9";
153 42 -> sLit "$f10"; 43 -> sLit "$f11";
154 44 -> sLit "$f12"; 45 -> sLit "$f13";
155 46 -> sLit "$f14"; 47 -> sLit "$f15";
156 48 -> sLit "$f16"; 49 -> sLit "$f17";
157 50 -> sLit "$f18"; 51 -> sLit "$f19";
158 52 -> sLit "$f20"; 53 -> sLit "$f21";
159 54 -> sLit "$f22"; 55 -> sLit "$f23";
160 56 -> sLit "$f24"; 57 -> sLit "$f25";
161 58 -> sLit "$f26"; 59 -> sLit "$f27";
162 60 -> sLit "$f28"; 61 -> sLit "$f29";
163 62 -> sLit "$f30"; 63 -> sLit "$f31";
164 _ -> sLit "very naughty alpha register"
168 ppr_reg_no :: MachRep -> Int -> Doc
169 ppr_reg_no I8 = ppr_reg_byte
170 ppr_reg_no I16 = ppr_reg_word
171 ppr_reg_no _ = ppr_reg_long
173 ppr_reg_byte i = ptext
175 0 -> sLit "%al"; 1 -> sLit "%bl";
176 2 -> sLit "%cl"; 3 -> sLit "%dl";
177 _ -> sLit "very naughty I386 byte register"
180 ppr_reg_word i = ptext
182 0 -> sLit "%ax"; 1 -> sLit "%bx";
183 2 -> sLit "%cx"; 3 -> sLit "%dx";
184 4 -> sLit "%si"; 5 -> sLit "%di";
185 6 -> sLit "%bp"; 7 -> sLit "%sp";
186 _ -> sLit "very naughty I386 word register"
189 ppr_reg_long i = ptext
191 0 -> sLit "%eax"; 1 -> sLit "%ebx";
192 2 -> sLit "%ecx"; 3 -> sLit "%edx";
193 4 -> sLit "%esi"; 5 -> sLit "%edi";
194 6 -> sLit "%ebp"; 7 -> sLit "%esp";
195 8 -> sLit "%fake0"; 9 -> sLit "%fake1";
196 10 -> sLit "%fake2"; 11 -> sLit "%fake3";
197 12 -> sLit "%fake4"; 13 -> sLit "%fake5";
198 _ -> sLit "very naughty I386 register"
202 #if x86_64_TARGET_ARCH
203 ppr_reg_no :: MachRep -> Int -> Doc
204 ppr_reg_no I8 = ppr_reg_byte
205 ppr_reg_no I16 = ppr_reg_word
206 ppr_reg_no I32 = ppr_reg_long
207 ppr_reg_no _ = ppr_reg_quad
209 ppr_reg_byte i = ptext
211 0 -> sLit "%al"; 1 -> sLit "%bl";
212 2 -> sLit "%cl"; 3 -> sLit "%dl";
213 4 -> sLit "%sil"; 5 -> sLit "%dil"; -- new 8-bit regs!
214 6 -> sLit "%bpl"; 7 -> sLit "%spl";
215 8 -> sLit "%r8b"; 9 -> sLit "%r9b";
216 10 -> sLit "%r10b"; 11 -> sLit "%r11b";
217 12 -> sLit "%r12b"; 13 -> sLit "%r13b";
218 14 -> sLit "%r14b"; 15 -> sLit "%r15b";
219 _ -> sLit "very naughty x86_64 byte register"
222 ppr_reg_word i = ptext
224 0 -> sLit "%ax"; 1 -> sLit "%bx";
225 2 -> sLit "%cx"; 3 -> sLit "%dx";
226 4 -> sLit "%si"; 5 -> sLit "%di";
227 6 -> sLit "%bp"; 7 -> sLit "%sp";
228 8 -> sLit "%r8w"; 9 -> sLit "%r9w";
229 10 -> sLit "%r10w"; 11 -> sLit "%r11w";
230 12 -> sLit "%r12w"; 13 -> sLit "%r13w";
231 14 -> sLit "%r14w"; 15 -> sLit "%r15w";
232 _ -> sLit "very naughty x86_64 word register"
235 ppr_reg_long i = ptext
237 0 -> sLit "%eax"; 1 -> sLit "%ebx";
238 2 -> sLit "%ecx"; 3 -> sLit "%edx";
239 4 -> sLit "%esi"; 5 -> sLit "%edi";
240 6 -> sLit "%ebp"; 7 -> sLit "%esp";
241 8 -> sLit "%r8d"; 9 -> sLit "%r9d";
242 10 -> sLit "%r10d"; 11 -> sLit "%r11d";
243 12 -> sLit "%r12d"; 13 -> sLit "%r13d";
244 14 -> sLit "%r14d"; 15 -> sLit "%r15d";
245 _ -> sLit "very naughty x86_64 register"
248 ppr_reg_quad i = ptext
250 0 -> sLit "%rax"; 1 -> sLit "%rbx";
251 2 -> sLit "%rcx"; 3 -> sLit "%rdx";
252 4 -> sLit "%rsi"; 5 -> sLit "%rdi";
253 6 -> sLit "%rbp"; 7 -> sLit "%rsp";
254 8 -> sLit "%r8"; 9 -> sLit "%r9";
255 10 -> sLit "%r10"; 11 -> sLit "%r11";
256 12 -> sLit "%r12"; 13 -> sLit "%r13";
257 14 -> sLit "%r14"; 15 -> sLit "%r15";
258 16 -> sLit "%xmm0"; 17 -> sLit "%xmm1";
259 18 -> sLit "%xmm2"; 19 -> sLit "%xmm3";
260 20 -> sLit "%xmm4"; 21 -> sLit "%xmm5";
261 22 -> sLit "%xmm6"; 23 -> sLit "%xmm7";
262 24 -> sLit "%xmm8"; 25 -> sLit "%xmm9";
263 26 -> sLit "%xmm10"; 27 -> sLit "%xmm11";
264 28 -> sLit "%xmm12"; 29 -> sLit "%xmm13";
265 30 -> sLit "%xmm14"; 31 -> sLit "%xmm15";
266 _ -> sLit "very naughty x86_64 register"
270 #if sparc_TARGET_ARCH
271 ppr_reg_no :: Int -> Doc
274 0 -> sLit "%g0"; 1 -> sLit "%g1";
275 2 -> sLit "%g2"; 3 -> sLit "%g3";
276 4 -> sLit "%g4"; 5 -> sLit "%g5";
277 6 -> sLit "%g6"; 7 -> sLit "%g7";
278 8 -> sLit "%o0"; 9 -> sLit "%o1";
279 10 -> sLit "%o2"; 11 -> sLit "%o3";
280 12 -> sLit "%o4"; 13 -> sLit "%o5";
281 14 -> sLit "%o6"; 15 -> sLit "%o7";
282 16 -> sLit "%l0"; 17 -> sLit "%l1";
283 18 -> sLit "%l2"; 19 -> sLit "%l3";
284 20 -> sLit "%l4"; 21 -> sLit "%l5";
285 22 -> sLit "%l6"; 23 -> sLit "%l7";
286 24 -> sLit "%i0"; 25 -> sLit "%i1";
287 26 -> sLit "%i2"; 27 -> sLit "%i3";
288 28 -> sLit "%i4"; 29 -> sLit "%i5";
289 30 -> sLit "%i6"; 31 -> sLit "%i7";
290 32 -> sLit "%f0"; 33 -> sLit "%f1";
291 34 -> sLit "%f2"; 35 -> sLit "%f3";
292 36 -> sLit "%f4"; 37 -> sLit "%f5";
293 38 -> sLit "%f6"; 39 -> sLit "%f7";
294 40 -> sLit "%f8"; 41 -> sLit "%f9";
295 42 -> sLit "%f10"; 43 -> sLit "%f11";
296 44 -> sLit "%f12"; 45 -> sLit "%f13";
297 46 -> sLit "%f14"; 47 -> sLit "%f15";
298 48 -> sLit "%f16"; 49 -> sLit "%f17";
299 50 -> sLit "%f18"; 51 -> sLit "%f19";
300 52 -> sLit "%f20"; 53 -> sLit "%f21";
301 54 -> sLit "%f22"; 55 -> sLit "%f23";
302 56 -> sLit "%f24"; 57 -> sLit "%f25";
303 58 -> sLit "%f26"; 59 -> sLit "%f27";
304 60 -> sLit "%f28"; 61 -> sLit "%f29";
305 62 -> sLit "%f30"; 63 -> sLit "%f31";
306 _ -> sLit "very naughty sparc register"
309 #if powerpc_TARGET_ARCH
311 ppr_reg_no :: Int -> Doc
314 0 -> sLit "r0"; 1 -> sLit "r1";
315 2 -> sLit "r2"; 3 -> sLit "r3";
316 4 -> sLit "r4"; 5 -> sLit "r5";
317 6 -> sLit "r6"; 7 -> sLit "r7";
318 8 -> sLit "r8"; 9 -> sLit "r9";
319 10 -> sLit "r10"; 11 -> sLit "r11";
320 12 -> sLit "r12"; 13 -> sLit "r13";
321 14 -> sLit "r14"; 15 -> sLit "r15";
322 16 -> sLit "r16"; 17 -> sLit "r17";
323 18 -> sLit "r18"; 19 -> sLit "r19";
324 20 -> sLit "r20"; 21 -> sLit "r21";
325 22 -> sLit "r22"; 23 -> sLit "r23";
326 24 -> sLit "r24"; 25 -> sLit "r25";
327 26 -> sLit "r26"; 27 -> sLit "r27";
328 28 -> sLit "r28"; 29 -> sLit "r29";
329 30 -> sLit "r30"; 31 -> sLit "r31";
330 32 -> sLit "f0"; 33 -> sLit "f1";
331 34 -> sLit "f2"; 35 -> sLit "f3";
332 36 -> sLit "f4"; 37 -> sLit "f5";
333 38 -> sLit "f6"; 39 -> sLit "f7";
334 40 -> sLit "f8"; 41 -> sLit "f9";
335 42 -> sLit "f10"; 43 -> sLit "f11";
336 44 -> sLit "f12"; 45 -> sLit "f13";
337 46 -> sLit "f14"; 47 -> sLit "f15";
338 48 -> sLit "f16"; 49 -> sLit "f17";
339 50 -> sLit "f18"; 51 -> sLit "f19";
340 52 -> sLit "f20"; 53 -> sLit "f21";
341 54 -> sLit "f22"; 55 -> sLit "f23";
342 56 -> sLit "f24"; 57 -> sLit "f25";
343 58 -> sLit "f26"; 59 -> sLit "f27";
344 60 -> sLit "f28"; 61 -> sLit "f29";
345 62 -> sLit "f30"; 63 -> sLit "f31";
346 _ -> sLit "very naughty powerpc register"
349 ppr_reg_no :: Int -> Doc
350 ppr_reg_no i | i <= 31 = int i -- GPRs
351 | i <= 63 = int (i-32) -- FPRs
352 | otherwise = ptext (sLit "very naughty powerpc register")
357 -- -----------------------------------------------------------------------------
358 -- pprSize: print a 'Size'
360 #if powerpc_TARGET_ARCH || i386_TARGET_ARCH || x86_64_TARGET_ARCH || sparc_TARGET_ARCH
361 pprSize :: MachRep -> Doc
363 pprSize :: Size -> Doc
366 pprSize x = ptext (case x of
367 #if alpha_TARGET_ARCH
370 -- W -> sLit "w" UNUSED
371 -- Wu -> sLit "wu" UNUSED
374 -- FF -> sLit "f" UNUSED
375 -- DF -> sLit "d" UNUSED
376 -- GF -> sLit "g" UNUSED
377 -- SF -> sLit "s" UNUSED
380 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
391 #if x86_64_TARGET_ARCH
392 F32 -> sLit "ss" -- "scalar single-precision float" (SSE2)
393 F64 -> sLit "sd" -- "scalar double-precision float" (SSE2)
395 #if sparc_TARGET_ARCH
402 pprStSize :: MachRep -> Doc
403 pprStSize x = ptext (case x of
410 #if powerpc_TARGET_ARCH
419 -- -----------------------------------------------------------------------------
420 -- pprCond: print a 'Cond'
422 pprCond :: Cond -> Doc
424 pprCond c = ptext (case c of {
425 #if alpha_TARGET_ARCH
435 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
436 GEU -> sLit "ae"; LU -> sLit "b";
437 EQQ -> sLit "e"; GTT -> sLit "g";
438 GE -> sLit "ge"; GU -> sLit "a";
439 LTT -> sLit "l"; LE -> sLit "le";
440 LEU -> sLit "be"; NE -> sLit "ne";
441 NEG -> sLit "s"; POS -> sLit "ns";
442 CARRY -> sLit "c"; OFLO -> sLit "o";
443 PARITY -> sLit "p"; NOTPARITY -> sLit "np";
444 ALWAYS -> sLit "mp" -- hack
446 #if sparc_TARGET_ARCH
447 ALWAYS -> sLit ""; NEVER -> sLit "n";
448 GEU -> sLit "geu"; LU -> sLit "lu";
449 EQQ -> sLit "e"; GTT -> sLit "g";
450 GE -> sLit "ge"; GU -> sLit "gu";
451 LTT -> sLit "l"; LE -> sLit "le";
452 LEU -> sLit "leu"; NE -> sLit "ne";
453 NEG -> sLit "neg"; POS -> sLit "pos";
454 VC -> sLit "vc"; VS -> sLit "vs"
456 #if powerpc_TARGET_ARCH
458 EQQ -> sLit "eq"; NE -> sLit "ne";
459 LTT -> sLit "lt"; GE -> sLit "ge";
460 GTT -> sLit "gt"; LE -> sLit "le";
461 LU -> sLit "lt"; GEU -> sLit "ge";
462 GU -> sLit "gt"; LEU -> sLit "le";
467 -- -----------------------------------------------------------------------------
468 -- pprImm: print an 'Imm'
472 pprImm (ImmInt i) = int i
473 pprImm (ImmInteger i) = integer i
474 pprImm (ImmCLbl l) = pprCLabel_asm l
475 pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i
476 pprImm (ImmLit s) = s
478 pprImm (ImmFloat _) = ptext (sLit "naughty float immediate")
479 pprImm (ImmDouble _) = ptext (sLit "naughty double immediate")
481 pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
482 #if sparc_TARGET_ARCH
483 -- ToDo: This should really be fixed in the PIC support, but only
485 pprImm (ImmConstantDiff a b) = pprImm a
487 pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
488 <> lparen <> pprImm b <> rparen
491 #if sparc_TARGET_ARCH
493 = hcat [ pp_lo, pprImm i, rparen ]
498 = hcat [ pp_hi, pprImm i, rparen ]
502 #if powerpc_TARGET_ARCH
505 = hcat [ pp_lo, pprImm i, rparen ]
510 = hcat [ pp_hi, pprImm i, rparen ]
515 = hcat [ pp_ha, pprImm i, rparen ]
521 = pprImm i <> text "@l"
524 = pprImm i <> text "@h"
527 = pprImm i <> text "@ha"
532 -- -----------------------------------------------------------------------------
533 -- @pprAddr: print an 'AddrMode'
535 pprAddr :: AddrMode -> Doc
537 #if alpha_TARGET_ARCH
538 pprAddr (AddrReg r) = parens (pprReg r)
539 pprAddr (AddrImm i) = pprImm i
540 pprAddr (AddrRegImm r1 i)
541 = (<>) (pprImm i) (parens (pprReg r1))
546 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
547 pprAddr (ImmAddr imm off)
548 = let pp_imm = pprImm imm
552 else if (off < 0) then
555 pp_imm <> char '+' <> int off
557 pprAddr (AddrBaseIndex base index displacement)
559 pp_disp = ppr_disp displacement
560 pp_off p = pp_disp <> char '(' <> p <> char ')'
561 pp_reg r = pprReg wordRep r
564 (EABaseNone, EAIndexNone) -> pp_disp
565 (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b)
566 (EABaseRip, EAIndexNone) -> pp_off (ptext (sLit "%rip"))
567 (EABaseNone, EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i)
568 (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r
571 ppr_disp (ImmInt 0) = empty
572 ppr_disp imm = pprImm imm
577 #if sparc_TARGET_ARCH
578 pprAddr (AddrRegReg r1 (RealReg 0)) = pprReg r1
580 pprAddr (AddrRegReg r1 r2)
581 = hcat [ pprReg r1, char '+', pprReg r2 ]
583 pprAddr (AddrRegImm r1 (ImmInt i))
585 | not (fits13Bits i) = largeOffsetError i
586 | otherwise = hcat [ pprReg r1, pp_sign, int i ]
588 pp_sign = if i > 0 then char '+' else empty
590 pprAddr (AddrRegImm r1 (ImmInteger i))
592 | not (fits13Bits i) = largeOffsetError i
593 | otherwise = hcat [ pprReg r1, pp_sign, integer i ]
595 pp_sign = if i > 0 then char '+' else empty
597 pprAddr (AddrRegImm r1 imm)
598 = hcat [ pprReg r1, char '+', pprImm imm ]
603 #if powerpc_TARGET_ARCH
604 pprAddr (AddrRegReg r1 r2)
605 = pprReg r1 <+> ptext (sLit ", ") <+> pprReg r2
607 pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ]
608 pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ]
609 pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]
613 -- -----------------------------------------------------------------------------
614 -- pprData: print a 'CmmStatic'
616 pprSectionHeader Text
618 (IF_ARCH_alpha(sLit "\t.text\n\t.align 3" {-word boundary-}
619 ,IF_ARCH_sparc(sLit ".text\n\t.align 4" {-word boundary-}
620 ,IF_ARCH_i386(IF_OS_darwin(sLit ".text\n\t.align 2",
621 sLit ".text\n\t.align 4,0x90")
622 {-needs per-OS variation!-}
623 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".text\n.align 3",
624 sLit ".text\n\t.align 8")
625 ,IF_ARCH_powerpc(sLit ".text\n.align 2"
627 pprSectionHeader Data
629 (IF_ARCH_alpha(sLit "\t.data\n\t.align 3"
630 ,IF_ARCH_sparc(sLit ".data\n\t.align 8" {-<8 will break double constants -}
631 ,IF_ARCH_i386(IF_OS_darwin(sLit ".data\n\t.align 2",
632 sLit ".data\n\t.align 4")
633 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".data\n.align 3",
634 sLit ".data\n\t.align 8")
635 ,IF_ARCH_powerpc(sLit ".data\n.align 2"
637 pprSectionHeader ReadOnlyData
639 (IF_ARCH_alpha(sLit "\t.data\n\t.align 3"
640 ,IF_ARCH_sparc(sLit ".data\n\t.align 8" {-<8 will break double constants -}
641 ,IF_ARCH_i386(IF_OS_darwin(sLit ".const\n.align 2",
642 sLit ".section .rodata\n\t.align 4")
643 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".const\n.align 3",
644 sLit ".section .rodata\n\t.align 8")
645 ,IF_ARCH_powerpc(IF_OS_darwin(sLit ".const\n.align 2",
646 sLit ".section .rodata\n\t.align 2")
648 pprSectionHeader RelocatableReadOnlyData
650 (IF_ARCH_alpha(sLit "\t.data\n\t.align 3"
651 ,IF_ARCH_sparc(sLit ".data\n\t.align 8" {-<8 will break double constants -}
652 ,IF_ARCH_i386(IF_OS_darwin(sLit ".const_data\n.align 2",
653 sLit ".section .data\n\t.align 4")
654 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".const_data\n.align 3",
655 sLit ".section .data\n\t.align 8")
656 ,IF_ARCH_powerpc(IF_OS_darwin(sLit ".const_data\n.align 2",
657 sLit ".data\n\t.align 2")
659 pprSectionHeader UninitialisedData
661 (IF_ARCH_alpha(sLit "\t.bss\n\t.align 3"
662 ,IF_ARCH_sparc(sLit ".bss\n\t.align 8" {-<8 will break double constants -}
663 ,IF_ARCH_i386(IF_OS_darwin(sLit ".data\n\t.align 2",
664 sLit ".section .bss\n\t.align 4")
665 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".data\n\t.align 3",
666 sLit ".section .bss\n\t.align 8")
667 ,IF_ARCH_powerpc(IF_OS_darwin(sLit ".const_data\n.align 2",
668 sLit ".section .bss\n\t.align 2")
670 pprSectionHeader ReadOnlyData16
672 (IF_ARCH_alpha(sLit "\t.data\n\t.align 4"
673 ,IF_ARCH_sparc(sLit ".data\n\t.align 16"
674 ,IF_ARCH_i386(IF_OS_darwin(sLit ".const\n.align 4",
675 sLit ".section .rodata\n\t.align 16")
676 ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".const\n.align 4",
677 sLit ".section .rodata.cst16\n\t.align 16")
678 ,IF_ARCH_powerpc(IF_OS_darwin(sLit ".const\n.align 4",
679 sLit ".section .rodata\n\t.align 4")
682 pprSectionHeader (OtherSection sec)
683 = panic "PprMach.pprSectionHeader: unknown section"
685 pprData :: CmmStatic -> Doc
686 pprData (CmmAlign bytes) = pprAlign bytes
687 pprData (CmmDataLabel lbl) = pprLabel lbl
688 pprData (CmmString str) = pprASCII str
689 pprData (CmmUninitialised bytes) = ptext (sLit ".space ") <> int bytes
690 pprData (CmmStaticLit lit) = pprDataItem lit
692 pprGloblDecl :: CLabel -> Doc
694 | not (externallyVisibleCLabel lbl) = empty
695 | otherwise = ptext IF_ARCH_sparc((sLit ".global "),
699 pprTypeAndSizeDecl :: CLabel -> Doc
700 pprTypeAndSizeDecl lbl
702 | not (externallyVisibleCLabel lbl) = empty
703 | otherwise = ptext (sLit ".type ") <>
704 pprCLabel_asm lbl <> ptext (sLit ", @object")
709 pprLabel :: CLabel -> Doc
710 pprLabel lbl = pprGloblDecl lbl $$ pprTypeAndSizeDecl lbl $$ (pprCLabel_asm lbl <> char ':')
714 = vcat (map do1 str) $$ do1 0
717 do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w)
720 IF_ARCH_alpha(ptext (sLit ".align ") <> int pow2,
721 IF_ARCH_i386(ptext (sLit ".align ") <> int IF_OS_darwin(pow2,bytes),
722 IF_ARCH_x86_64(ptext (sLit ".align ") <> int IF_OS_darwin(pow2,bytes),
723 IF_ARCH_sparc(ptext (sLit ".align ") <> int bytes,
724 IF_ARCH_powerpc(ptext (sLit ".align ") <> int pow2,)))))
728 log2 :: Int -> Int -- cache the common ones
733 log2 n = 1 + log2 (n `quot` 2)
736 pprDataItem :: CmmLit -> Doc
738 = vcat (ppr_item (cmmLitRep lit) lit)
742 -- These seem to be common:
743 ppr_item I8 x = [ptext (sLit "\t.byte\t") <> pprImm imm]
744 ppr_item I32 x = [ptext (sLit "\t.long\t") <> pprImm imm]
745 ppr_item F32 (CmmFloat r _)
746 = let bs = floatToBytes (fromRational r)
747 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
748 ppr_item F64 (CmmFloat r _)
749 = let bs = doubleToBytes (fromRational r)
750 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
752 #if sparc_TARGET_ARCH
753 -- copy n paste of x86 version
754 ppr_item I16 x = [ptext (sLit "\t.short\t") <> pprImm imm]
755 ppr_item I64 x = [ptext (sLit "\t.quad\t") <> pprImm imm]
757 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
758 ppr_item I16 x = [ptext (sLit "\t.word\t") <> pprImm imm]
760 #if i386_TARGET_ARCH && darwin_TARGET_OS
761 ppr_item I64 (CmmInt x _) =
762 [ptext (sLit "\t.long\t")
763 <> int (fromIntegral (fromIntegral x :: Word32)),
764 ptext (sLit "\t.long\t")
766 (fromIntegral (x `shiftR` 32) :: Word32))]
768 #if i386_TARGET_ARCH || (darwin_TARGET_OS && x86_64_TARGET_ARCH)
769 ppr_item I64 x = [ptext (sLit "\t.quad\t") <> pprImm imm]
771 #if x86_64_TARGET_ARCH && !darwin_TARGET_OS
772 -- x86_64: binutils can't handle the R_X86_64_PC64 relocation
773 -- type, which means we can't do pc-relative 64-bit addresses.
774 -- Fortunately we're assuming the small memory model, in which
775 -- all such offsets will fit into 32 bits, so we have to stick
776 -- to 32-bit offset fields and modify the RTS appropriately
778 -- See Note [x86-64-relative] in includes/InfoTables.h
781 | isRelativeReloc x =
782 [ptext (sLit "\t.long\t") <> pprImm imm,
783 ptext (sLit "\t.long\t0")]
785 [ptext (sLit "\t.quad\t") <> pprImm imm]
787 isRelativeReloc (CmmLabelDiffOff _ _ _) = True
788 isRelativeReloc _ = False
790 #if powerpc_TARGET_ARCH
791 ppr_item I16 x = [ptext (sLit "\t.short\t") <> pprImm imm]
792 ppr_item I64 (CmmInt x _) =
793 [ptext (sLit "\t.long\t")
795 (fromIntegral (x `shiftR` 32) :: Word32)),
796 ptext (sLit "\t.long\t")
797 <> int (fromIntegral (fromIntegral x :: Word32))]
800 -- fall through to rest of (machine-specific) pprInstr...
802 -- -----------------------------------------------------------------------------
803 -- pprInstr: print an 'Instr'
805 instance Outputable Instr where
806 ppr instr = Outputable.docToSDoc $ pprInstr instr
808 pprInstr :: Instr -> Doc
810 --pprInstr (COMMENT s) = empty -- nuke 'em
812 = IF_ARCH_alpha( ((<>) (ptext (sLit "\t# ")) (ftext s))
813 ,IF_ARCH_sparc( ((<>) (ptext (sLit "! ")) (ftext s))
814 ,IF_ARCH_i386( ((<>) (ptext (sLit "# ")) (ftext s))
815 ,IF_ARCH_x86_64( ((<>) (ptext (sLit "# ")) (ftext s))
816 ,IF_ARCH_powerpc( IF_OS_linux(
817 ((<>) (ptext (sLit "# ")) (ftext s)),
818 ((<>) (ptext (sLit "; ")) (ftext s)))
822 = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
824 pprInstr (NEWBLOCK _)
825 = panic "PprMach.pprInstr: NEWBLOCK"
828 = panic "PprMach.pprInstr: LDATA"
830 -- -----------------------------------------------------------------------------
831 -- pprInstr for an Alpha
833 #if alpha_TARGET_ARCH
835 pprInstr (SPILL reg slot)
837 ptext (sLit "\tSPILL"),
841 ptext (sLit "SLOT") <> parens (int slot)]
843 pprInstr (RELOAD slot reg)
845 ptext (sLit "\tRELOAD"),
847 ptext (sLit "SLOT") <> parens (int slot),
851 pprInstr (LD size reg addr)
861 pprInstr (LDA reg addr)
863 ptext (sLit "\tlda\t"),
869 pprInstr (LDAH reg addr)
871 ptext (sLit "\tldah\t"),
877 pprInstr (LDGP reg addr)
879 ptext (sLit "\tldgp\t"),
885 pprInstr (LDI size reg imm)
887 ptext (sLit "\tldi"),
895 pprInstr (ST size reg addr)
907 ptext (sLit "\tclr\t"),
911 pprInstr (ABS size ri reg)
913 ptext (sLit "\tabs"),
921 pprInstr (NEG size ov ri reg)
923 ptext (sLit "\tneg"),
925 if ov then ptext (sLit "v\t") else char '\t',
931 pprInstr (ADD size ov reg1 ri reg2)
933 ptext (sLit "\tadd"),
935 if ov then ptext (sLit "v\t") else char '\t',
943 pprInstr (SADD size scale reg1 ri reg2)
945 ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
956 pprInstr (SUB size ov reg1 ri reg2)
958 ptext (sLit "\tsub"),
960 if ov then ptext (sLit "v\t") else char '\t',
968 pprInstr (SSUB size scale reg1 ri reg2)
970 ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
981 pprInstr (MUL size ov reg1 ri reg2)
983 ptext (sLit "\tmul"),
985 if ov then ptext (sLit "v\t") else char '\t',
993 pprInstr (DIV size uns reg1 ri reg2)
995 ptext (sLit "\tdiv"),
997 if uns then ptext (sLit "u\t") else char '\t',
1005 pprInstr (REM size uns reg1 ri reg2)
1007 ptext (sLit "\trem"),
1009 if uns then ptext (sLit "u\t") else char '\t',
1017 pprInstr (NOT ri reg)
1019 ptext (sLit "\tnot"),
1026 pprInstr (AND reg1 ri reg2) = pprRegRIReg (sLit "and") reg1 ri reg2
1027 pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg (sLit "andnot") reg1 ri reg2
1028 pprInstr (OR reg1 ri reg2) = pprRegRIReg (sLit "or") reg1 ri reg2
1029 pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg (sLit "ornot") reg1 ri reg2
1030 pprInstr (XOR reg1 ri reg2) = pprRegRIReg (sLit "xor") reg1 ri reg2
1031 pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg (sLit "xornot") reg1 ri reg2
1033 pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") reg1 ri reg2
1034 pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") reg1 ri reg2
1035 pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") reg1 ri reg2
1037 pprInstr (ZAP reg1 ri reg2) = pprRegRIReg (sLit "zap") reg1 ri reg2
1038 pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg (sLit "zapnot") reg1 ri reg2
1040 pprInstr (NOP) = ptext (sLit "\tnop")
1042 pprInstr (CMP cond reg1 ri reg2)
1044 ptext (sLit "\tcmp"),
1056 ptext (sLit "\tfclr\t"),
1060 pprInstr (FABS reg1 reg2)
1062 ptext (sLit "\tfabs\t"),
1068 pprInstr (FNEG size reg1 reg2)
1070 ptext (sLit "\tneg"),
1078 pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "add") size reg1 reg2 reg3
1079 pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "div") size reg1 reg2 reg3
1080 pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "mul") size reg1 reg2 reg3
1081 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "sub") size reg1 reg2 reg3
1083 pprInstr (CVTxy size1 size2 reg1 reg2)
1085 ptext (sLit "\tcvt"),
1087 case size2 of {Q -> ptext (sLit "qc"); _ -> pprSize size2},
1094 pprInstr (FCMP size cond reg1 reg2 reg3)
1096 ptext (sLit "\tcmp"),
1107 pprInstr (FMOV reg1 reg2)
1109 ptext (sLit "\tfmov\t"),
1115 pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
1117 pprInstr (BI NEVER reg lab) = empty
1119 pprInstr (BI cond reg lab)
1129 pprInstr (BF cond reg lab)
1131 ptext (sLit "\tfb"),
1140 = (<>) (ptext (sLit "\tbr\t")) (pprImm lab)
1142 pprInstr (JMP reg addr hint)
1144 ptext (sLit "\tjmp\t"),
1152 pprInstr (BSR imm n)
1153 = (<>) (ptext (sLit "\tbsr\t")) (pprImm imm)
1155 pprInstr (JSR reg addr n)
1157 ptext (sLit "\tjsr\t"),
1163 pprInstr (FUNBEGIN clab)
1165 if (externallyVisibleCLabel clab) then
1166 hcat [ptext (sLit "\t.globl\t"), pp_lab, char '\n']
1169 ptext (sLit "\t.ent "),
1178 pp_lab = pprCLabel_asm clab
1180 -- NEVER use commas within those string literals, cpp will ruin your day
1181 pp_ldgp = hcat [ ptext (sLit ":\n\tldgp $29"), char ',', ptext (sLit "0($27)\n") ]
1182 pp_frame = hcat [ ptext (sLit "..ng:\n\t.frame $30"), char ',',
1183 ptext (sLit "4240"), char ',',
1184 ptext (sLit "$26"), char ',',
1185 ptext (sLit "0\n\t.prologue 1") ]
1187 pprInstr (FUNEND clab)
1188 = (<>) (ptext (sLit "\t.align 4\n\t.end ")) (pprCLabel_asm clab)
1191 Continue with Alpha-only printing bits and bobs:
1195 pprRI (RIReg r) = pprReg r
1196 pprRI (RIImm r) = pprImm r
1198 pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
1199 pprRegRIReg name reg1 ri reg2
1211 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1212 pprSizeRegRegReg name size reg1 reg2 reg3
1225 #endif /* alpha_TARGET_ARCH */
1228 -- -----------------------------------------------------------------------------
1229 -- pprInstr for an x86
1231 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1233 pprInstr (SPILL reg slot)
1235 ptext (sLit "\tSPILL"),
1239 ptext (sLit "SLOT") <> parens (int slot)]
1241 pprInstr (RELOAD slot reg)
1243 ptext (sLit "\tRELOAD"),
1245 ptext (sLit "SLOT") <> parens (int slot),
1249 pprInstr (MOV size src dst)
1250 = pprSizeOpOp (sLit "mov") size src dst
1252 pprInstr (MOVZxL I32 src dst) = pprSizeOpOp (sLit "mov") I32 src dst
1253 -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple
1254 -- movl. But we represent it as a MOVZxL instruction, because
1255 -- the reg alloc would tend to throw away a plain reg-to-reg
1256 -- move, and we still want it to do that.
1258 pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce (sLit "movz") sizes I32 src dst
1259 -- zero-extension only needs to extend to 32 bits: on x86_64,
1260 -- the remaining zero-extension to 64 bits is automatic, and the 32-bit
1261 -- instruction is shorter.
1263 pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce (sLit "movs") sizes wordRep src dst
1265 -- here we do some patching, since the physical registers are only set late
1266 -- in the code generation.
1267 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1269 = pprSizeOpOp (sLit "add") size (OpReg reg2) dst
1270 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1272 = pprSizeOpOp (sLit "add") size (OpReg reg1) dst
1273 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))
1275 = pprInstr (ADD size (OpImm displ) dst)
1276 pprInstr (LEA size src dst) = pprSizeOpOp (sLit "lea") size src dst
1278 pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
1279 = pprSizeOp (sLit "dec") size dst
1280 pprInstr (ADD size (OpImm (ImmInt 1)) dst)
1281 = pprSizeOp (sLit "inc") size dst
1282 pprInstr (ADD size src dst)
1283 = pprSizeOpOp (sLit "add") size src dst
1284 pprInstr (ADC size src dst)
1285 = pprSizeOpOp (sLit "adc") size src dst
1286 pprInstr (SUB size src dst) = pprSizeOpOp (sLit "sub") size src dst
1287 pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2
1289 {- A hack. The Intel documentation says that "The two and three
1290 operand forms [of IMUL] may also be used with unsigned operands
1291 because the lower half of the product is the same regardless if
1292 (sic) the operands are signed or unsigned. The CF and OF flags,
1293 however, cannot be used to determine if the upper half of the
1294 result is non-zero." So there.
1296 pprInstr (AND size src dst) = pprSizeOpOp (sLit "and") size src dst
1297 pprInstr (OR size src dst) = pprSizeOpOp (sLit "or") size src dst
1299 pprInstr (XOR F32 src dst) = pprOpOp (sLit "xorps") F32 src dst
1300 pprInstr (XOR F64 src dst) = pprOpOp (sLit "xorpd") F64 src dst
1301 pprInstr (XOR size src dst) = pprSizeOpOp (sLit "xor") size src dst
1303 pprInstr (NOT size op) = pprSizeOp (sLit "not") size op
1304 pprInstr (NEGI size op) = pprSizeOp (sLit "neg") size op
1306 pprInstr (SHL size src dst) = pprShift (sLit "shl") size src dst
1307 pprInstr (SAR size src dst) = pprShift (sLit "sar") size src dst
1308 pprInstr (SHR size src dst) = pprShift (sLit "shr") size src dst
1310 pprInstr (BT size imm src) = pprSizeImmOp (sLit "bt") size imm src
1312 pprInstr (CMP size src dst)
1313 | isFloatingRep size = pprSizeOpOp (sLit "ucomi") size src dst -- SSE2
1314 | otherwise = pprSizeOpOp (sLit "cmp") size src dst
1316 pprInstr (TEST size src dst) = pprSizeOpOp (sLit "test") size src dst
1317 pprInstr (PUSH size op) = pprSizeOp (sLit "push") size op
1318 pprInstr (POP size op) = pprSizeOp (sLit "pop") size op
1320 -- both unused (SDM):
1321 -- pprInstr PUSHA = ptext (sLit "\tpushal")
1322 -- pprInstr POPA = ptext (sLit "\tpopal")
1324 pprInstr NOP = ptext (sLit "\tnop")
1325 pprInstr (CLTD I32) = ptext (sLit "\tcltd")
1326 pprInstr (CLTD I64) = ptext (sLit "\tcqto")
1328 pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand I8 op)
1330 pprInstr (JXX cond (BlockId id))
1331 = pprCondInstr (sLit "j") cond (pprCLabel_asm lab)
1332 where lab = mkAsmTempLabel id
1334 pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm)
1336 pprInstr (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm)
1337 pprInstr (JMP op) = (<>) (ptext (sLit "\tjmp *")) (pprOperand wordRep op)
1338 pprInstr (JMP_TBL op ids) = pprInstr (JMP op)
1339 pprInstr (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm)
1340 pprInstr (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg wordRep reg)
1342 pprInstr (IDIV sz op) = pprSizeOp (sLit "idiv") sz op
1343 pprInstr (DIV sz op) = pprSizeOp (sLit "div") sz op
1344 pprInstr (IMUL2 sz op) = pprSizeOp (sLit "imul") sz op
1346 #if x86_64_TARGET_ARCH
1347 pprInstr (MUL size op1 op2) = pprSizeOpOp (sLit "mul") size op1 op2
1349 pprInstr (FDIV size op1 op2) = pprSizeOpOp (sLit "div") size op1 op2
1351 pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to
1352 pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to
1353 pprInstr (CVTTSS2SIQ from to) = pprOpReg (sLit "cvttss2siq") from to
1354 pprInstr (CVTTSD2SIQ from to) = pprOpReg (sLit "cvttsd2siq") from to
1355 pprInstr (CVTSI2SS from to) = pprOpReg (sLit "cvtsi2ssq") from to
1356 pprInstr (CVTSI2SD from to) = pprOpReg (sLit "cvtsi2sdq") from to
1359 -- FETCHGOT for PIC on ELF platforms
1360 pprInstr (FETCHGOT reg)
1361 = vcat [ ptext (sLit "\tcall 1f"),
1362 hcat [ ptext (sLit "1:\tpopl\t"), pprReg I32 reg ],
1363 hcat [ ptext (sLit "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "),
1367 -- FETCHPC for PIC on Darwin/x86
1368 -- get the instruction pointer into a register
1369 -- (Terminology note: the IP is called Program Counter on PPC,
1370 -- and it's a good thing to use the same name on both platforms)
1371 pprInstr (FETCHPC reg)
1372 = vcat [ ptext (sLit "\tcall 1f"),
1373 hcat [ ptext (sLit "1:\tpopl\t"), pprReg I32 reg ]
1380 -- -----------------------------------------------------------------------------
1381 -- i386 floating-point
1383 #if i386_TARGET_ARCH
1384 -- Simulating a flat register set on the x86 FP stack is tricky.
1385 -- you have to free %st(7) before pushing anything on the FP reg stack
1386 -- so as to preclude the possibility of a FP stack overflow exception.
1387 pprInstr g@(GMOV src dst)
1391 = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
1393 -- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FSTP (dst+1)
1394 pprInstr g@(GLD sz addr dst)
1395 = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp,
1396 pprAddr addr, gsemi, gpop dst 1])
1398 -- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
1399 pprInstr g@(GST sz src addr)
1400 = pprG g (hcat [gtab, gpush src 0, gsemi,
1401 text "fstp", pprSize sz, gsp, pprAddr addr])
1403 pprInstr g@(GLDZ dst)
1404 = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1])
1405 pprInstr g@(GLD1 dst)
1406 = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1])
1408 pprInstr g@(GFTOI src dst)
1409 = pprInstr (GDTOI src dst)
1410 pprInstr g@(GDTOI src dst)
1412 hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"],
1413 hcat [gtab, gpush src 0],
1414 hcat [gtab, text "movzwl 4(%esp), ", reg,
1415 text " ; orl $0xC00, ", reg],
1416 hcat [gtab, text "movl ", reg, text ", 0(%esp) ; fldcw 0(%esp)"],
1417 hcat [gtab, text "fistpl 0(%esp)"],
1418 hcat [gtab, text "fldcw 4(%esp) ; movl 0(%esp), ", reg],
1419 hcat [gtab, text "addl $8, %esp"]
1422 reg = pprReg I32 dst
1424 pprInstr g@(GITOF src dst)
1425 = pprInstr (GITOD src dst)
1426 pprInstr g@(GITOD src dst)
1427 = pprG g (hcat [gtab, text "pushl ", pprReg I32 src,
1428 text " ; ffree %st(7); fildl (%esp) ; ",
1429 gpop dst 1, text " ; addl $4,%esp"])
1431 {- Gruesome swamp follows. If you're unfortunate enough to have ventured
1432 this far into the jungle AND you give a Rat's Ass (tm) what's going
1433 on, here's the deal. Generate code to do a floating point comparison
1434 of src1 and src2, of kind cond, and set the Zero flag if true.
1436 The complications are to do with handling NaNs correctly. We want the
1437 property that if either argument is NaN, then the result of the
1438 comparison is False ... except if we're comparing for inequality,
1439 in which case the answer is True.
1441 Here's how the general (non-inequality) case works. As an
1442 example, consider generating the an equality test:
1444 pushl %eax -- we need to mess with this
1445 <get src1 to top of FPU stack>
1446 fcomp <src2 location in FPU stack> and pop pushed src1
1447 -- Result of comparison is in FPU Status Register bits
1449 fstsw %ax -- Move FPU Status Reg to %ax
1450 sahf -- move C3 C2 C0 from %ax to integer flag reg
1451 -- now the serious magic begins
1452 setpo %ah -- %ah = if comparable(neither arg was NaN) then 1 else 0
1453 sete %al -- %al = if arg1 == arg2 then 1 else 0
1454 andb %ah,%al -- %al &= %ah
1455 -- so %al == 1 iff (comparable && same); else it holds 0
1456 decb %al -- %al == 0, ZeroFlag=1 iff (comparable && same);
1457 else %al == 0xFF, ZeroFlag=0
1458 -- the zero flag is now set as we desire.
1461 The special case of inequality differs thusly:
1463 setpe %ah -- %ah = if incomparable(either arg was NaN) then 1 else 0
1464 setne %al -- %al = if arg1 /= arg2 then 1 else 0
1465 orb %ah,%al -- %al = if (incomparable || different) then 1 else 0
1466 decb %al -- if (incomparable || different) then (%al == 0, ZF=1)
1467 else (%al == 0xFF, ZF=0)
1469 pprInstr g@(GCMP cond src1 src2)
1470 | case cond of { NE -> True; other -> False }
1472 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1473 hcat [gtab, text "fcomp ", greg src2 1,
1474 text "; fstsw %ax ; sahf ; setpe %ah"],
1475 hcat [gtab, text "setne %al ; ",
1476 text "orb %ah,%al ; decb %al ; popl %eax"]
1480 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1481 hcat [gtab, text "fcomp ", greg src2 1,
1482 text "; fstsw %ax ; sahf ; setpo %ah"],
1483 hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ; ",
1484 text "andb %ah,%al ; decb %al ; popl %eax"]
1487 {- On the 486, the flags set by FP compare are the unsigned ones!
1488 (This looks like a HACK to me. WDP 96/03)
1490 fix_FP_cond :: Cond -> Cond
1491 fix_FP_cond GE = GEU
1492 fix_FP_cond GTT = GU
1493 fix_FP_cond LTT = LU
1494 fix_FP_cond LE = LEU
1495 fix_FP_cond EQQ = EQQ
1497 -- there should be no others
1500 pprInstr g@(GABS sz src dst)
1501 = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
1502 pprInstr g@(GNEG sz src dst)
1503 = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
1505 pprInstr g@(GSQRT sz src dst)
1506 = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
1507 hcat [gtab, gcoerceto sz, gpop dst 1])
1508 pprInstr g@(GSIN sz l1 l2 src dst)
1509 = pprG g (pprTrigOp "fsin" False l1 l2 src dst sz)
1510 pprInstr g@(GCOS sz l1 l2 src dst)
1511 = pprG g (pprTrigOp "fcos" False l1 l2 src dst sz)
1512 pprInstr g@(GTAN sz l1 l2 src dst)
1513 = pprG g (pprTrigOp "fptan" True l1 l2 src dst sz)
1515 -- In the translations for GADD, GMUL, GSUB and GDIV,
1516 -- the first two cases are mere optimisations. The otherwise clause
1517 -- generates correct code under all circumstances.
1519 pprInstr g@(GADD sz src1 src2 dst)
1521 = pprG g (text "\t#GADD-xxxcase1" $$
1522 hcat [gtab, gpush src2 0,
1523 text " ; faddp %st(0),", greg src1 1])
1525 = pprG g (text "\t#GADD-xxxcase2" $$
1526 hcat [gtab, gpush src1 0,
1527 text " ; faddp %st(0),", greg src2 1])
1529 = pprG g (hcat [gtab, gpush src1 0,
1530 text " ; fadd ", greg src2 1, text ",%st(0)",
1534 pprInstr g@(GMUL sz src1 src2 dst)
1536 = pprG g (text "\t#GMUL-xxxcase1" $$
1537 hcat [gtab, gpush src2 0,
1538 text " ; fmulp %st(0),", greg src1 1])
1540 = pprG g (text "\t#GMUL-xxxcase2" $$
1541 hcat [gtab, gpush src1 0,
1542 text " ; fmulp %st(0),", greg src2 1])
1544 = pprG g (hcat [gtab, gpush src1 0,
1545 text " ; fmul ", greg src2 1, text ",%st(0)",
1549 pprInstr g@(GSUB sz src1 src2 dst)
1551 = pprG g (text "\t#GSUB-xxxcase1" $$
1552 hcat [gtab, gpush src2 0,
1553 text " ; fsubrp %st(0),", greg src1 1])
1555 = pprG g (text "\t#GSUB-xxxcase2" $$
1556 hcat [gtab, gpush src1 0,
1557 text " ; fsubp %st(0),", greg src2 1])
1559 = pprG g (hcat [gtab, gpush src1 0,
1560 text " ; fsub ", greg src2 1, text ",%st(0)",
1564 pprInstr g@(GDIV sz src1 src2 dst)
1566 = pprG g (text "\t#GDIV-xxxcase1" $$
1567 hcat [gtab, gpush src2 0,
1568 text " ; fdivrp %st(0),", greg src1 1])
1570 = pprG g (text "\t#GDIV-xxxcase2" $$
1571 hcat [gtab, gpush src1 0,
1572 text " ; fdivp %st(0),", greg src2 1])
1574 = pprG g (hcat [gtab, gpush src1 0,
1575 text " ; fdiv ", greg src2 1, text ",%st(0)",
1580 = vcat [ ptext (sLit "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
1581 ptext (sLit "\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)")
1584 pprTrigOp :: String -> Bool -> CLabel -> CLabel -> Reg -> Reg -> MachRep -> Doc
1585 pprTrigOp op -- fsin, fcos or fptan
1586 isTan -- we need a couple of extra steps if we're doing tan
1587 l1 l2 -- internal labels for us to use
1589 = -- We'll be needing %eax later on
1590 hcat [gtab, text "pushl %eax;"] $$
1591 -- tan is going to use an extra space on the FP stack
1592 (if isTan then hcat [gtab, text "ffree %st(6)"] else empty) $$
1593 -- First put the value in %st(0) and try to apply the op to it
1594 hcat [gpush src 0, text ("; " ++ op)] $$
1595 -- Now look to see if C2 was set (overflow, |value| >= 2^63)
1596 hcat [gtab, text "fnstsw %ax"] $$
1597 hcat [gtab, text "test $0x400,%eax"] $$
1598 -- If we were in bounds then jump to the end
1599 hcat [gtab, text "je " <> pprCLabel_asm l1] $$
1600 -- Otherwise we need to shrink the value. Start by
1601 -- loading pi, doubleing it (by adding it to itself),
1602 -- and then swapping pi with the value, so the value we
1603 -- want to apply op to is in %st(0) again
1604 hcat [gtab, text "ffree %st(7); fldpi"] $$
1605 hcat [gtab, text "fadd %st(0),%st"] $$
1606 hcat [gtab, text "fxch %st(1)"] $$
1607 -- Now we have a loop in which we make the value smaller,
1608 -- see if it's small enough, and loop if not
1609 (pprCLabel_asm l2 <> char ':') $$
1610 hcat [gtab, text "fprem1"] $$
1611 -- My Debian libc uses fstsw here for the tan code, but I can't
1612 -- see any reason why it should need to be different for tan.
1613 hcat [gtab, text "fnstsw %ax"] $$
1614 hcat [gtab, text "test $0x400,%eax"] $$
1615 hcat [gtab, text "jne " <> pprCLabel_asm l2] $$
1616 hcat [gtab, text "fstp %st(1)"] $$
1617 hcat [gtab, text op] $$
1618 (pprCLabel_asm l1 <> char ':') $$
1619 -- Pop the 1.0 tan gave us
1620 (if isTan then hcat [gtab, text "fstp %st(0)"] else empty) $$
1622 hcat [gtab, text "popl %eax;"] $$
1623 -- And finally make the result the right size
1624 hcat [gtab, gcoerceto sz, gpop dst 1]
1626 --------------------------
1628 -- coerce %st(0) to the specified size
1629 gcoerceto F64 = empty
1630 gcoerceto F32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
1633 = hcat [text "ffree %st(7) ; fld ", greg reg offset]
1635 = hcat [text "fstp ", greg reg offset]
1637 greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
1642 gregno (RealReg i) = i
1643 gregno other = --pprPanic "gregno" (ppr other)
1644 999 -- bogus; only needed for debug printing
1646 pprG :: Instr -> Doc -> Doc
1648 = (char '#' <> pprGInstr fake) $$ actual
1650 pprGInstr (GMOV src dst) = pprSizeRegReg (sLit "gmov") F64 src dst
1651 pprGInstr (GLD sz src dst) = pprSizeAddrReg (sLit "gld") sz src dst
1652 pprGInstr (GST sz src dst) = pprSizeRegAddr (sLit "gst") sz src dst
1654 pprGInstr (GLDZ dst) = pprSizeReg (sLit "gldz") F64 dst
1655 pprGInstr (GLD1 dst) = pprSizeReg (sLit "gld1") F64 dst
1657 pprGInstr (GFTOI src dst) = pprSizeSizeRegReg (sLit "gftoi") F32 I32 src dst
1658 pprGInstr (GDTOI src dst) = pprSizeSizeRegReg (sLit "gdtoi") F64 I32 src dst
1660 pprGInstr (GITOF src dst) = pprSizeSizeRegReg (sLit "gitof") I32 F32 src dst
1661 pprGInstr (GITOD src dst) = pprSizeSizeRegReg (sLit "gitod") I32 F64 src dst
1663 pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") F64 co src dst
1664 pprGInstr (GABS sz src dst) = pprSizeRegReg (sLit "gabs") sz src dst
1665 pprGInstr (GNEG sz src dst) = pprSizeRegReg (sLit "gneg") sz src dst
1666 pprGInstr (GSQRT sz src dst) = pprSizeRegReg (sLit "gsqrt") sz src dst
1667 pprGInstr (GSIN sz _ _ src dst) = pprSizeRegReg (sLit "gsin") sz src dst
1668 pprGInstr (GCOS sz _ _ src dst) = pprSizeRegReg (sLit "gcos") sz src dst
1669 pprGInstr (GTAN sz _ _ src dst) = pprSizeRegReg (sLit "gtan") sz src dst
1671 pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg (sLit "gadd") sz src1 src2 dst
1672 pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg (sLit "gsub") sz src1 src2 dst
1673 pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg (sLit "gmul") sz src1 src2 dst
1674 pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg (sLit "gdiv") sz src1 src2 dst
1677 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1679 -- Continue with I386-only printing bits and bobs:
1681 pprDollImm :: Imm -> Doc
1683 pprDollImm i = ptext (sLit "$") <> pprImm i
1685 pprOperand :: MachRep -> Operand -> Doc
1686 pprOperand s (OpReg r) = pprReg s r
1687 pprOperand s (OpImm i) = pprDollImm i
1688 pprOperand s (OpAddr ea) = pprAddr ea
1690 pprMnemonic_ :: LitString -> Doc
1692 char '\t' <> ptext name <> space
1694 pprMnemonic :: LitString -> MachRep -> Doc
1695 pprMnemonic name size =
1696 char '\t' <> ptext name <> pprSize size <> space
1698 pprSizeImmOp :: LitString -> MachRep -> Imm -> Operand -> Doc
1699 pprSizeImmOp name size imm op1
1701 pprMnemonic name size,
1708 pprSizeOp :: LitString -> MachRep -> Operand -> Doc
1709 pprSizeOp name size op1
1711 pprMnemonic name size,
1715 pprSizeOpOp :: LitString -> MachRep -> Operand -> Operand -> Doc
1716 pprSizeOpOp name size op1 op2
1718 pprMnemonic name size,
1719 pprOperand size op1,
1724 pprOpOp :: LitString -> MachRep -> Operand -> Operand -> Doc
1725 pprOpOp name size op1 op2
1728 pprOperand size op1,
1733 pprSizeReg :: LitString -> MachRep -> Reg -> Doc
1734 pprSizeReg name size reg1
1736 pprMnemonic name size,
1740 pprSizeRegReg :: LitString -> MachRep -> Reg -> Reg -> Doc
1741 pprSizeRegReg name size reg1 reg2
1743 pprMnemonic name size,
1749 pprRegReg :: LitString -> Reg -> Reg -> Doc
1750 pprRegReg name reg1 reg2
1753 pprReg wordRep reg1,
1758 pprOpReg :: LitString -> Operand -> Reg -> Doc
1759 pprOpReg name op1 reg2
1762 pprOperand wordRep op1,
1767 pprCondRegReg :: LitString -> MachRep -> Cond -> Reg -> Reg -> Doc
1768 pprCondRegReg name size cond reg1 reg2
1779 pprSizeSizeRegReg :: LitString -> MachRep -> MachRep -> Reg -> Reg -> Doc
1780 pprSizeSizeRegReg name size1 size2 reg1 reg2
1793 pprSizeRegRegReg :: LitString -> MachRep -> Reg -> Reg -> Reg -> Doc
1794 pprSizeRegRegReg name size reg1 reg2 reg3
1796 pprMnemonic name size,
1804 pprSizeAddrReg :: LitString -> MachRep -> AddrMode -> Reg -> Doc
1805 pprSizeAddrReg name size op dst
1807 pprMnemonic name size,
1813 pprSizeRegAddr :: LitString -> MachRep -> Reg -> AddrMode -> Doc
1814 pprSizeRegAddr name size src op
1816 pprMnemonic name size,
1822 pprShift :: LitString -> MachRep -> Operand -> Operand -> Doc
1823 pprShift name size src dest
1825 pprMnemonic name size,
1826 pprOperand I8 src, -- src is 8-bit sized
1828 pprOperand size dest
1831 pprSizeOpOpCoerce :: LitString -> MachRep -> MachRep -> Operand -> Operand -> Doc
1832 pprSizeOpOpCoerce name size1 size2 op1 op2
1833 = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
1834 pprOperand size1 op1,
1836 pprOperand size2 op2
1839 pprCondInstr :: LitString -> Cond -> Doc -> Doc
1840 pprCondInstr name cond arg
1841 = hcat [ char '\t', ptext name, pprCond cond, space, arg]
1843 #endif /* i386_TARGET_ARCH */
1846 -- ------------------------------------------------------------------------------- pprInstr for a SPARC
1848 #if sparc_TARGET_ARCH
1850 -- a clumsy hack for now, to handle possible double alignment problems
1852 -- even clumsier, to allow for RegReg regs that show when doing indexed
1853 -- reads (bytearrays).
1856 pprInstr (SPILL reg slot)
1858 ptext (sLit "\tSPILL"),
1862 ptext (sLit "SLOT") <> parens (int slot)]
1864 pprInstr (RELOAD slot reg)
1866 ptext (sLit "\tRELOAD"),
1868 ptext (sLit "SLOT") <> parens (int slot),
1872 -- Translate to the following:
1875 -- ld [g1+4],%f(n+1)
1876 -- sub g1,g2,g1 -- to restore g1
1878 pprInstr (LD F64 (AddrRegReg g1 g2) reg)
1880 hcat [ptext (sLit "\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1881 hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg],
1882 hcat [pp_ld_lbracket, pprReg g1, ptext (sLit "+4]"), comma, pprReg (fPair reg)],
1883 hcat [ptext (sLit "\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1888 -- ld [addr+4],%f(n+1)
1889 pprInstr (LD F64 addr reg) | isJust off_addr
1891 hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
1892 hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg (fPair reg)]
1895 off_addr = addrOffset addr 4
1896 addr2 = case off_addr of Just x -> x
1899 pprInstr (LD size addr reg)
1901 ptext (sLit "\tld"),
1910 -- The same clumsy hack as above
1912 -- Translate to the following:
1915 -- st %f(n+1),[g1+4]
1916 -- sub g1,g2,g1 -- to restore g1
1917 pprInstr (ST F64 reg (AddrRegReg g1 g2))
1919 hcat [ptext (sLit "\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1920 hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket,
1922 hcat [ptext (sLit "\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1923 pprReg g1, ptext (sLit "+4]")],
1924 hcat [ptext (sLit "\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1929 -- st %f(n+1),[addr+4]
1930 pprInstr (ST F64 reg addr) | isJust off_addr
1932 hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket,
1933 pprAddr addr, rbrack],
1934 hcat [ptext (sLit "\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1935 pprAddr addr2, rbrack]
1938 off_addr = addrOffset addr 4
1939 addr2 = case off_addr of Just x -> x
1941 -- no distinction is made between signed and unsigned bytes on stores for the
1942 -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
1943 -- so we call a special-purpose pprSize for ST..
1945 pprInstr (ST size reg addr)
1947 ptext (sLit "\tst"),
1956 pprInstr (ADD x cc reg1 ri reg2)
1957 | not x && not cc && riZero ri
1958 = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1960 = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2
1962 pprInstr (SUB x cc reg1 ri reg2)
1963 | not x && cc && reg2 == g0
1964 = hcat [ ptext (sLit "\tcmp\t"), pprReg reg1, comma, pprRI ri ]
1965 | not x && not cc && riZero ri
1966 = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1968 = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2
1970 pprInstr (AND b reg1 ri reg2) = pprRegRIReg (sLit "and") b reg1 ri reg2
1971 pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2
1973 pprInstr (OR b reg1 ri reg2)
1974 | not b && reg1 == g0
1975 = let doit = hcat [ ptext (sLit "\tmov\t"), pprRI ri, comma, pprReg reg2 ]
1977 RIReg rrr | rrr == reg2 -> empty
1980 = pprRegRIReg (sLit "or") b reg1 ri reg2
1982 pprInstr (ORN b reg1 ri reg2) = pprRegRIReg (sLit "orn") b reg1 ri reg2
1984 pprInstr (XOR b reg1 ri reg2) = pprRegRIReg (sLit "xor") b reg1 ri reg2
1985 pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg (sLit "xnor") b reg1 ri reg2
1987 pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") False reg1 ri reg2
1988 pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") False reg1 ri reg2
1989 pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") False reg1 ri reg2
1991 pprInstr (RDY rd) = ptext (sLit "\trd\t%y,") <> pprReg rd
1992 pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul") b reg1 ri reg2
1993 pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul") b reg1 ri reg2
1995 pprInstr (SETHI imm reg)
1997 ptext (sLit "\tsethi\t"),
2003 pprInstr NOP = ptext (sLit "\tnop")
2005 pprInstr (FABS F32 reg1 reg2) = pprSizeRegReg (sLit "fabs") F32 reg1 reg2
2006 pprInstr (FABS F64 reg1 reg2)
2007 = (<>) (pprSizeRegReg (sLit "fabs") F32 reg1 reg2)
2008 (if (reg1 == reg2) then empty
2009 else (<>) (char '\n')
2010 (pprSizeRegReg (sLit "fmov") F32 (fPair reg1) (fPair reg2)))
2012 pprInstr (FADD size reg1 reg2 reg3)
2013 = pprSizeRegRegReg (sLit "fadd") size reg1 reg2 reg3
2014 pprInstr (FCMP e size reg1 reg2)
2015 = pprSizeRegReg (if e then sLit "fcmpe" else sLit "fcmp") size reg1 reg2
2016 pprInstr (FDIV size reg1 reg2 reg3)
2017 = pprSizeRegRegReg (sLit "fdiv") size reg1 reg2 reg3
2019 pprInstr (FMOV F32 reg1 reg2) = pprSizeRegReg (sLit "fmov") F32 reg1 reg2
2020 pprInstr (FMOV F64 reg1 reg2)
2021 = (<>) (pprSizeRegReg (sLit "fmov") F32 reg1 reg2)
2022 (if (reg1 == reg2) then empty
2023 else (<>) (char '\n')
2024 (pprSizeRegReg (sLit "fmov") F32 (fPair reg1) (fPair reg2)))
2026 pprInstr (FMUL size reg1 reg2 reg3)
2027 = pprSizeRegRegReg (sLit "fmul") size reg1 reg2 reg3
2029 pprInstr (FNEG F32 reg1 reg2) = pprSizeRegReg (sLit "fneg") F32 reg1 reg2
2030 pprInstr (FNEG F64 reg1 reg2)
2031 = (<>) (pprSizeRegReg (sLit "fneg") F32 reg1 reg2)
2032 (if (reg1 == reg2) then empty
2033 else (<>) (char '\n')
2034 (pprSizeRegReg (sLit "fmov") F32 (fPair reg1) (fPair reg2)))
2036 pprInstr (FSQRT size reg1 reg2) = pprSizeRegReg (sLit "fsqrt") size reg1 reg2
2037 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fsub") size reg1 reg2 reg3
2038 pprInstr (FxTOy size1 size2 reg1 reg2)
2051 pprReg reg1, comma, pprReg reg2
2055 pprInstr (BI cond b lab)
2057 ptext (sLit "\tb"), pprCond cond,
2058 if b then pp_comma_a else empty,
2063 pprInstr (BF cond b lab)
2065 ptext (sLit "\tfb"), pprCond cond,
2066 if b then pp_comma_a else empty,
2071 pprInstr (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr addr)
2073 pprInstr (CALL (Left imm) n _)
2074 = hcat [ ptext (sLit "\tcall\t"), pprImm imm, comma, int n ]
2075 pprInstr (CALL (Right reg) n _)
2076 = hcat [ ptext (sLit "\tcall\t"), pprReg reg, comma, int n ]
2079 pprRI (RIReg r) = pprReg r
2080 pprRI (RIImm r) = pprImm r
2082 pprSizeRegReg :: LitString -> MachRep -> Reg -> Reg -> Doc
2083 pprSizeRegReg name size reg1 reg2
2088 F32 -> ptext (sLit "s\t")
2089 F64 -> ptext (sLit "d\t")),
2095 pprSizeRegRegReg :: LitString -> MachRep -> Reg -> Reg -> Reg -> Doc
2096 pprSizeRegRegReg name size reg1 reg2 reg3
2101 F32 -> ptext (sLit "s\t")
2102 F64 -> ptext (sLit "d\t")),
2110 pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
2111 pprRegRIReg name b reg1 ri reg2
2115 if b then ptext (sLit "cc\t") else char '\t',
2123 pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
2124 pprRIReg name b ri reg1
2128 if b then ptext (sLit "cc\t") else char '\t',
2134 pp_ld_lbracket = ptext (sLit "\tld\t[")
2135 pp_rbracket_comma = text "],"
2136 pp_comma_lbracket = text ",["
2137 pp_comma_a = text ",a"
2139 #endif /* sparc_TARGET_ARCH */
2142 -- -----------------------------------------------------------------------------
2143 -- pprInstr for PowerPC
2145 #if powerpc_TARGET_ARCH
2147 pprInstr (SPILL reg slot)
2149 ptext (sLit "\tSPILL"),
2153 ptext (sLit "SLOT") <> parens (int slot)]
2155 pprInstr (RELOAD slot reg)
2157 ptext (sLit "\tRELOAD"),
2159 ptext (sLit "SLOT") <> parens (int slot),
2163 pprInstr (LD sz reg addr) = hcat [
2172 case addr of AddrRegImm _ _ -> empty
2173 AddrRegReg _ _ -> char 'x',
2179 pprInstr (LA sz reg addr) = hcat [
2188 case addr of AddrRegImm _ _ -> empty
2189 AddrRegReg _ _ -> char 'x',
2195 pprInstr (ST sz reg addr) = hcat [
2199 case addr of AddrRegImm _ _ -> empty
2200 AddrRegReg _ _ -> char 'x',
2206 pprInstr (STU sz reg addr) = hcat [
2211 case addr of AddrRegImm _ _ -> empty
2212 AddrRegReg _ _ -> char 'x',
2217 pprInstr (LIS reg imm) = hcat [
2225 pprInstr (LI reg imm) = hcat [
2233 pprInstr (MR reg1 reg2)
2234 | reg1 == reg2 = empty
2235 | otherwise = hcat [
2237 case regClass reg1 of
2238 RcInteger -> ptext (sLit "mr")
2239 _ -> ptext (sLit "fmr"),
2245 pprInstr (CMP sz reg ri) = hcat [
2261 pprInstr (CMPL sz reg ri) = hcat [
2271 ptext (sLit "cmpl"),
2277 pprInstr (BCC cond (BlockId id)) = hcat [
2284 where lbl = mkAsmTempLabel id
2286 pprInstr (BCCFAR cond (BlockId id)) = vcat [
2289 pprCond (condNegate cond),
2290 ptext (sLit "\t$+8")
2293 ptext (sLit "\tb\t"),
2297 where lbl = mkAsmTempLabel id
2299 pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
2306 pprInstr (MTCTR reg) = hcat [
2308 ptext (sLit "mtctr"),
2312 pprInstr (BCTR _) = hcat [
2316 pprInstr (BL lbl _) = hcat [
2317 ptext (sLit "\tbl\t"),
2320 pprInstr (BCTRL _) = hcat [
2322 ptext (sLit "bctrl")
2324 pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri
2325 pprInstr (ADDIS reg1 reg2 imm) = hcat [
2327 ptext (sLit "addis"),
2336 pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3)
2337 pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3)
2338 pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3)
2339 pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri
2340 pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri
2341 pprInstr (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3)
2342 pprInstr (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3)
2344 pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
2345 hcat [ ptext (sLit "\tmullwo\t"), pprReg reg1, ptext (sLit ", "),
2346 pprReg reg2, ptext (sLit ", "),
2348 hcat [ ptext (sLit "\tmfxer\t"), pprReg reg1 ],
2349 hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "),
2350 pprReg reg1, ptext (sLit ", "),
2351 ptext (sLit "2, 31, 31") ]
2354 -- for some reason, "andi" doesn't exist.
2355 -- we'll use "andi." instead.
2356 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
2358 ptext (sLit "andi."),
2366 pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri
2368 pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri
2369 pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri
2371 pprInstr (XORIS reg1 reg2 imm) = hcat [
2373 ptext (sLit "xoris"),
2382 pprInstr (EXTS sz reg1 reg2) = hcat [
2384 ptext (sLit "exts"),
2392 pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2
2393 pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2
2395 pprInstr (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri)
2396 pprInstr (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri)
2397 pprInstr (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri)
2398 pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
2399 ptext (sLit "\trlwinm\t"),
2411 pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF (sLit "fadd") sz reg1 reg2 reg3
2412 pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF (sLit "fsub") sz reg1 reg2 reg3
2413 pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF (sLit "fmul") sz reg1 reg2 reg3
2414 pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") sz reg1 reg2 reg3
2415 pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2
2417 pprInstr (FCMP reg1 reg2) = hcat [
2419 ptext (sLit "fcmpu\tcr0, "),
2420 -- Note: we're using fcmpu, not fcmpo
2421 -- The difference is with fcmpo, compare with NaN is an invalid operation.
2422 -- We don't handle invalid fp ops, so we don't care
2428 pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2
2429 pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2
2431 pprInstr (CRNOR dst src1 src2) = hcat [
2432 ptext (sLit "\tcrnor\t"),
2440 pprInstr (MFCR reg) = hcat [
2442 ptext (sLit "mfcr"),
2447 pprInstr (MFLR reg) = hcat [
2449 ptext (sLit "mflr"),
2454 pprInstr (FETCHPC reg) = vcat [
2455 ptext (sLit "\tbcl\t20,31,1f"),
2456 hcat [ ptext (sLit "1:\tmflr\t"), pprReg reg ]
2459 pprInstr LWSYNC = ptext (sLit "\tlwsync")
2461 pprInstr _ = panic "pprInstr (ppc)"
2463 pprLogic op reg1 reg2 ri = hcat [
2468 RIImm _ -> char 'i',
2477 pprUnary op reg1 reg2 = hcat [
2486 pprBinaryF op sz reg1 reg2 reg3 = hcat [
2499 pprRI (RIReg r) = pprReg r
2500 pprRI (RIImm r) = pprImm r
2502 pprFSize F64 = empty
2503 pprFSize F32 = char 's'
2505 -- limit immediate argument for shift instruction to range 0..32
2506 -- (yes, the maximum is really 32, not 31)
2507 limitShiftRI :: RI -> RI
2508 limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32)
2511 #endif /* powerpc_TARGET_ARCH */
2514 -- -----------------------------------------------------------------------------
2515 -- Converting floating-point literals to integrals for printing
2517 castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)
2518 castFloatToWord8Array = castSTUArray
2520 castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8)
2521 castDoubleToWord8Array = castSTUArray
2523 -- floatToBytes and doubleToBytes convert to the host's byte
2524 -- order. Providing that we're not cross-compiling for a
2525 -- target with the opposite endianness, this should work ok
2528 -- ToDo: this stuff is very similar to the shenanigans in PprAbs,
2529 -- could they be merged?
2531 floatToBytes :: Float -> [Int]
2534 arr <- newArray_ ((0::Int),3)
2536 arr <- castFloatToWord8Array arr
2537 i0 <- readArray arr 0
2538 i1 <- readArray arr 1
2539 i2 <- readArray arr 2
2540 i3 <- readArray arr 3
2541 return (map fromIntegral [i0,i1,i2,i3])
2544 doubleToBytes :: Double -> [Int]
2547 arr <- newArray_ ((0::Int),7)
2549 arr <- castDoubleToWord8Array arr
2550 i0 <- readArray arr 0
2551 i1 <- readArray arr 1
2552 i2 <- readArray arr 2
2553 i3 <- readArray arr 3
2554 i4 <- readArray arr 4
2555 i5 <- readArray arr 5
2556 i6 <- readArray arr 6
2557 i7 <- readArray arr 7
2558 return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7])