1 -----------------------------------------------------------------------------
3 -- Pretty-printing assembly language
5 -- (c) The University of Glasgow 1993-2005
7 -----------------------------------------------------------------------------
23 #include "HsVersions.h"
24 #include "nativeGen/NCG.h"
38 import Unique ( pprUnique, Uniquable(..) )
41 import qualified Outputable
42 import Outputable (panic, Outputable)
45 import Distribution.System
47 #if i386_TARGET_ARCH && darwin_TARGET_OS
51 -- -----------------------------------------------------------------------------
52 -- Printing this stuff out
54 pprNatCmmTop :: NatCmmTop Instr -> Doc
55 pprNatCmmTop (CmmData section dats) =
56 pprSectionHeader section $$ vcat (map pprData dats)
58 -- special case for split markers:
59 pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel True lbl
61 pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) =
62 pprSectionHeader Text $$
63 (if null info then -- blocks guaranteed not null, so label needed
66 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
67 pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
70 vcat (map pprData info) $$
71 pprLabel True (entryLblToInfoLbl lbl)
73 vcat (map pprBasicBlock blocks)
74 -- above: Even the first block gets a label, because with branch-chain
75 -- elimination, it might be the target of a goto.
76 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
77 -- If we are using the .subsections_via_symbols directive
78 -- (available on recent versions of Darwin),
79 -- we have to make sure that there is some kind of reference
80 -- from the entry code to a label on the _top_ of of the info table,
81 -- so that the linker will not think it is unreferenced and dead-strip
82 -- it. That's why the label is called a DeadStripPreventer (_dsp).
85 <+> pprCLabel_asm (entryLblToInfoLbl lbl)
87 <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
90 $$ pprSizeDecl (if null info then lbl else entryLblToInfoLbl lbl)
93 pprBasicBlock :: NatBasicBlock Instr -> Doc
94 pprBasicBlock (BasicBlock blockid instrs) =
95 pprCLabel_asm (mkAsmTempLabel (getUnique blockid)) <> char ':' $$
96 vcat (map pprInstr instrs)
99 pprData :: CmmStatic -> Doc
100 pprData (CmmAlign bytes) = pprAlign bytes
101 pprData (CmmDataLabel lbl) = pprLabel False lbl
102 pprData (CmmString str) = pprASCII str
105 pprData (CmmUninitialised bytes) = ptext (sLit ".space ") <> int bytes
107 pprData (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes
110 pprData (CmmStaticLit lit) = pprDataItem lit
112 pprGloblDecl :: CLabel -> Doc
114 | not (externallyVisibleCLabel lbl) = empty
115 | otherwise = ptext IF_ARCH_sparc((sLit ".global "),
119 pprTypeDecl :: Bool -> CLabel -> Doc
121 pprTypeDecl isCode lbl =
122 ptext (sLit "\t.type ") <> pprCLabel_asm lbl
123 <> ptext (sLit (if isCode then ", @function" else ", @object"))
129 -- | Output the ELF .size directive.
130 pprSizeDecl :: CLabel -> Doc
133 ptext (sLit "\t.size") <+> pprCLabel_asm lbl
134 <> ptext (sLit ", .-") <> pprCLabel_asm lbl
136 pprSizeDecl _ = empty
139 pprLabel :: Bool -> CLabel -> Doc
140 pprLabel isCode lbl = pprGloblDecl lbl $$ pprTypeDecl isCode lbl
141 $$ (pprCLabel_asm lbl <> char ':')
144 pprASCII :: [Word8] -> Doc
146 = vcat (map do1 str) $$ do1 0
149 do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w)
151 pprAlign :: Int -> Doc
155 = ptext (sLit ".align ") <> int IF_OS_darwin(pow2, bytes)
161 log2 :: Int -> Int -- cache the common ones
166 log2 n = 1 + log2 (n `quot` 2)
169 -- -----------------------------------------------------------------------------
170 -- pprInstr: print an 'Instr'
172 instance Outputable Instr where
173 ppr instr = Outputable.docToSDoc $ pprInstr instr
176 pprUserReg :: Reg -> Doc
178 | cTargetArch == I386 = pprReg II32
179 | cTargetArch == X86_64 = pprReg II64
180 | otherwise = panic "X86.Ppr.pprUserReg: not defined"
182 pprReg :: Size -> Reg -> Doc
186 RegReal (RealRegSingle i) -> ppr_reg_no s i
187 RegReal (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch"
188 RegVirtual (VirtualRegI u) -> text "%vI_" <> asmSDoc (pprUnique u)
189 RegVirtual (VirtualRegHi u) -> text "%vHi_" <> asmSDoc (pprUnique u)
190 RegVirtual (VirtualRegF u) -> text "%vF_" <> asmSDoc (pprUnique u)
191 RegVirtual (VirtualRegD u) -> text "%vD_" <> asmSDoc (pprUnique u)
192 RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> asmSDoc (pprUnique u)
195 ppr_reg_no :: Size -> Int -> Doc
196 ppr_reg_no II8 = ppr_reg_byte
197 ppr_reg_no II16 = ppr_reg_word
198 ppr_reg_no _ = ppr_reg_long
200 ppr_reg_byte i = ptext
202 0 -> sLit "%al"; 1 -> sLit "%bl";
203 2 -> sLit "%cl"; 3 -> sLit "%dl";
204 _ -> sLit "very naughty I386 byte register"
207 ppr_reg_word i = ptext
209 0 -> sLit "%ax"; 1 -> sLit "%bx";
210 2 -> sLit "%cx"; 3 -> sLit "%dx";
211 4 -> sLit "%si"; 5 -> sLit "%di";
212 6 -> sLit "%bp"; 7 -> sLit "%sp";
213 _ -> sLit "very naughty I386 word register"
216 ppr_reg_long i = ptext
218 0 -> sLit "%eax"; 1 -> sLit "%ebx";
219 2 -> sLit "%ecx"; 3 -> sLit "%edx";
220 4 -> sLit "%esi"; 5 -> sLit "%edi";
221 6 -> sLit "%ebp"; 7 -> sLit "%esp";
224 #elif x86_64_TARGET_ARCH
225 ppr_reg_no :: Size -> Int -> Doc
226 ppr_reg_no II8 = ppr_reg_byte
227 ppr_reg_no II16 = ppr_reg_word
228 ppr_reg_no II32 = ppr_reg_long
229 ppr_reg_no _ = ppr_reg_quad
231 ppr_reg_byte i = ptext
233 0 -> sLit "%al"; 1 -> sLit "%bl";
234 2 -> sLit "%cl"; 3 -> sLit "%dl";
235 4 -> sLit "%sil"; 5 -> sLit "%dil"; -- new 8-bit regs!
236 6 -> sLit "%bpl"; 7 -> sLit "%spl";
237 8 -> sLit "%r8b"; 9 -> sLit "%r9b";
238 10 -> sLit "%r10b"; 11 -> sLit "%r11b";
239 12 -> sLit "%r12b"; 13 -> sLit "%r13b";
240 14 -> sLit "%r14b"; 15 -> sLit "%r15b";
241 _ -> sLit "very naughty x86_64 byte register"
244 ppr_reg_word i = ptext
246 0 -> sLit "%ax"; 1 -> sLit "%bx";
247 2 -> sLit "%cx"; 3 -> sLit "%dx";
248 4 -> sLit "%si"; 5 -> sLit "%di";
249 6 -> sLit "%bp"; 7 -> sLit "%sp";
250 8 -> sLit "%r8w"; 9 -> sLit "%r9w";
251 10 -> sLit "%r10w"; 11 -> sLit "%r11w";
252 12 -> sLit "%r12w"; 13 -> sLit "%r13w";
253 14 -> sLit "%r14w"; 15 -> sLit "%r15w";
254 _ -> sLit "very naughty x86_64 word register"
257 ppr_reg_long i = ptext
259 0 -> sLit "%eax"; 1 -> sLit "%ebx";
260 2 -> sLit "%ecx"; 3 -> sLit "%edx";
261 4 -> sLit "%esi"; 5 -> sLit "%edi";
262 6 -> sLit "%ebp"; 7 -> sLit "%esp";
263 8 -> sLit "%r8d"; 9 -> sLit "%r9d";
264 10 -> sLit "%r10d"; 11 -> sLit "%r11d";
265 12 -> sLit "%r12d"; 13 -> sLit "%r13d";
266 14 -> sLit "%r14d"; 15 -> sLit "%r15d";
267 _ -> sLit "very naughty x86_64 register"
270 ppr_reg_quad i = ptext
272 0 -> sLit "%rax"; 1 -> sLit "%rbx";
273 2 -> sLit "%rcx"; 3 -> sLit "%rdx";
274 4 -> sLit "%rsi"; 5 -> sLit "%rdi";
275 6 -> sLit "%rbp"; 7 -> sLit "%rsp";
276 8 -> sLit "%r8"; 9 -> sLit "%r9";
277 10 -> sLit "%r10"; 11 -> sLit "%r11";
278 12 -> sLit "%r12"; 13 -> sLit "%r13";
279 14 -> sLit "%r14"; 15 -> sLit "%r15";
283 ppr_reg_no _ = panic "X86.Ppr.ppr_reg_no: no match"
286 #if defined(i386_TARGET_ARCH) || defined(x86_64_TARGET_ARCH)
287 ppr_reg_float :: Int -> LitString
288 ppr_reg_float i = case i of
289 16 -> sLit "%fake0"; 17 -> sLit "%fake1"
290 18 -> sLit "%fake2"; 19 -> sLit "%fake3"
291 20 -> sLit "%fake4"; 21 -> sLit "%fake5"
292 24 -> sLit "%xmm0"; 25 -> sLit "%xmm1"
293 26 -> sLit "%xmm2"; 27 -> sLit "%xmm3"
294 28 -> sLit "%xmm4"; 29 -> sLit "%xmm5"
295 30 -> sLit "%xmm6"; 31 -> sLit "%xmm7"
296 32 -> sLit "%xmm8"; 33 -> sLit "%xmm9"
297 34 -> sLit "%xmm10"; 35 -> sLit "%xmm11"
298 36 -> sLit "%xmm12"; 37 -> sLit "%xmm13"
299 38 -> sLit "%xmm14"; 39 -> sLit "%xmm15"
300 _ -> sLit "very naughty x86 register"
303 pprSize :: Size -> Doc
310 FF32 -> sLit "ss" -- "scalar single-precision float" (SSE2)
311 FF64 -> sLit "sd" -- "scalar double-precision float" (SSE2)
315 pprSize_x87 :: Size -> Doc
321 _ -> panic "X86.Ppr.pprSize_x87"
323 pprCond :: Cond -> Doc
326 GEU -> sLit "ae"; LU -> sLit "b";
327 EQQ -> sLit "e"; GTT -> sLit "g";
328 GE -> sLit "ge"; GU -> sLit "a";
329 LTT -> sLit "l"; LE -> sLit "le";
330 LEU -> sLit "be"; NE -> sLit "ne";
331 NEG -> sLit "s"; POS -> sLit "ns";
332 CARRY -> sLit "c"; OFLO -> sLit "o";
333 PARITY -> sLit "p"; NOTPARITY -> sLit "np";
334 ALWAYS -> sLit "mp"})
338 pprImm (ImmInt i) = int i
339 pprImm (ImmInteger i) = integer i
340 pprImm (ImmCLbl l) = pprCLabel_asm l
341 pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i
342 pprImm (ImmLit s) = s
344 pprImm (ImmFloat _) = ptext (sLit "naughty float immediate")
345 pprImm (ImmDouble _) = ptext (sLit "naughty double immediate")
347 pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
348 pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
349 <> lparen <> pprImm b <> rparen
353 pprAddr :: AddrMode -> Doc
354 pprAddr (ImmAddr imm off)
355 = let pp_imm = pprImm imm
359 else if (off < 0) then
362 pp_imm <> char '+' <> int off
364 pprAddr (AddrBaseIndex base index displacement)
366 pp_disp = ppr_disp displacement
367 pp_off p = pp_disp <> char '(' <> p <> char ')'
368 pp_reg r = pprReg archWordSize r
370 case (base, index) of
371 (EABaseNone, EAIndexNone) -> pp_disp
372 (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b)
373 (EABaseRip, EAIndexNone) -> pp_off (ptext (sLit "%rip"))
374 (EABaseNone, EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i)
375 (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r
377 _ -> panic "X86.Ppr.pprAddr: no match"
380 ppr_disp (ImmInt 0) = empty
381 ppr_disp imm = pprImm imm
384 pprSectionHeader :: Section -> Doc
387 # if darwin_TARGET_OS
390 Text -> ptext (sLit ".text\n\t.align 2")
391 Data -> ptext (sLit ".data\n\t.align 2")
392 ReadOnlyData -> ptext (sLit ".const\n.align 2")
393 RelocatableReadOnlyData -> ptext (sLit ".const_data\n.align 2")
394 UninitialisedData -> ptext (sLit ".data\n\t.align 2")
395 ReadOnlyData16 -> ptext (sLit ".const\n.align 4")
396 OtherSection _ -> panic "X86.Ppr.pprSectionHeader: unknown section"
401 Text -> ptext (sLit ".text\n\t.align 4,0x90")
402 Data -> ptext (sLit ".data\n\t.align 4")
403 ReadOnlyData -> ptext (sLit ".section .rodata\n\t.align 4")
404 RelocatableReadOnlyData -> ptext (sLit ".section .data\n\t.align 4")
405 UninitialisedData -> ptext (sLit ".section .bss\n\t.align 4")
406 ReadOnlyData16 -> ptext (sLit ".section .rodata\n\t.align 16")
407 OtherSection _ -> panic "X86.Ppr.pprSectionHeader: unknown section"
411 #elif x86_64_TARGET_ARCH
412 # if darwin_TARGET_OS
415 Text -> ptext (sLit ".text\n.align 3")
416 Data -> ptext (sLit ".data\n.align 3")
417 ReadOnlyData -> ptext (sLit ".const\n.align 3")
418 RelocatableReadOnlyData -> ptext (sLit ".const_data\n.align 3")
419 UninitialisedData -> ptext (sLit ".data\n\t.align 3")
420 ReadOnlyData16 -> ptext (sLit ".const\n.align 4")
421 OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section"
426 Text -> ptext (sLit ".text\n\t.align 8")
427 Data -> ptext (sLit ".data\n\t.align 8")
428 ReadOnlyData -> ptext (sLit ".section .rodata\n\t.align 8")
429 RelocatableReadOnlyData -> ptext (sLit ".section .data\n\t.align 8")
430 UninitialisedData -> ptext (sLit ".section .bss\n\t.align 8")
431 ReadOnlyData16 -> ptext (sLit ".section .rodata.cst16\n\t.align 16")
432 OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section"
437 pprSectionHeader _ = panic "X86.Ppr.pprSectionHeader: not defined for this architecture"
444 pprDataItem :: CmmLit -> Doc
446 = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit)
450 -- These seem to be common:
451 ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm imm]
452 ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm imm]
454 ppr_item FF32 (CmmFloat r _)
455 = let bs = floatToBytes (fromRational r)
456 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
458 ppr_item FF64 (CmmFloat r _)
459 = let bs = doubleToBytes (fromRational r)
460 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
462 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
463 ppr_item II16 _ = [ptext (sLit "\t.word\t") <> pprImm imm]
465 #if i386_TARGET_ARCH && darwin_TARGET_OS
466 ppr_item II64 (CmmInt x _) =
467 [ptext (sLit "\t.long\t")
468 <> int (fromIntegral (fromIntegral x :: Word32)),
469 ptext (sLit "\t.long\t")
471 (fromIntegral (x `shiftR` 32) :: Word32))]
473 #if i386_TARGET_ARCH || (darwin_TARGET_OS && x86_64_TARGET_ARCH)
474 ppr_item II64 _ = [ptext (sLit "\t.quad\t") <> pprImm imm]
476 #if x86_64_TARGET_ARCH && !darwin_TARGET_OS
477 -- x86_64: binutils can't handle the R_X86_64_PC64 relocation
478 -- type, which means we can't do pc-relative 64-bit addresses.
479 -- Fortunately we're assuming the small memory model, in which
480 -- all such offsets will fit into 32 bits, so we have to stick
481 -- to 32-bit offset fields and modify the RTS appropriately
483 -- See Note [x86-64-relative] in includes/rts/storage/InfoTables.h
486 | isRelativeReloc x =
487 [ptext (sLit "\t.long\t") <> pprImm imm,
488 ptext (sLit "\t.long\t0")]
490 [ptext (sLit "\t.quad\t") <> pprImm imm]
492 isRelativeReloc (CmmLabelDiffOff _ _ _) = True
493 isRelativeReloc _ = False
497 = panic "X86.Ppr.ppr_item: no match"
501 pprInstr :: Instr -> Doc
503 pprInstr (COMMENT _) = empty -- nuke 'em
506 = IF_ARCH_alpha( ((<>) (ptext (sLit "\t# ")) (ftext s))
507 ,IF_ARCH_sparc( ((<>) (ptext (sLit "# ")) (ftext s))
508 ,IF_ARCH_i386( ((<>) (ptext (sLit "# ")) (ftext s))
509 ,IF_ARCH_x86_64( ((<>) (ptext (sLit "# ")) (ftext s))
510 ,IF_ARCH_powerpc( IF_OS_linux(
511 ((<>) (ptext (sLit "# ")) (ftext s)),
512 ((<>) (ptext (sLit "; ")) (ftext s)))
516 = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
518 pprInstr (NEWBLOCK _)
519 = panic "PprMach.pprInstr: NEWBLOCK"
522 = panic "PprMach.pprInstr: LDATA"
525 pprInstr (SPILL reg slot)
527 ptext (sLit "\tSPILL"),
531 ptext (sLit "SLOT") <> parens (int slot)]
533 pprInstr (RELOAD slot reg)
535 ptext (sLit "\tRELOAD"),
537 ptext (sLit "SLOT") <> parens (int slot),
542 pprInstr (MOV size src dst)
543 = pprSizeOpOp (sLit "mov") size src dst
545 pprInstr (MOVZxL II32 src dst) = pprSizeOpOp (sLit "mov") II32 src dst
546 -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple
547 -- movl. But we represent it as a MOVZxL instruction, because
548 -- the reg alloc would tend to throw away a plain reg-to-reg
549 -- move, and we still want it to do that.
551 pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce (sLit "movz") sizes II32 src dst
552 -- zero-extension only needs to extend to 32 bits: on x86_64,
553 -- the remaining zero-extension to 64 bits is automatic, and the 32-bit
554 -- instruction is shorter.
556 pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce (sLit "movs") sizes archWordSize src dst
558 -- here we do some patching, since the physical registers are only set late
559 -- in the code generation.
560 pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
562 = pprSizeOpOp (sLit "add") size (OpReg reg2) dst
564 pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
566 = pprSizeOpOp (sLit "add") size (OpReg reg1) dst
568 pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))
570 = pprInstr (ADD size (OpImm displ) dst)
572 pprInstr (LEA size src dst) = pprSizeOpOp (sLit "lea") size src dst
574 pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
575 = pprSizeOp (sLit "dec") size dst
576 pprInstr (ADD size (OpImm (ImmInt 1)) dst)
577 = pprSizeOp (sLit "inc") size dst
578 pprInstr (ADD size src dst)
579 = pprSizeOpOp (sLit "add") size src dst
580 pprInstr (ADC size src dst)
581 = pprSizeOpOp (sLit "adc") size src dst
582 pprInstr (SUB size src dst) = pprSizeOpOp (sLit "sub") size src dst
583 pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2
585 {- A hack. The Intel documentation says that "The two and three
586 operand forms [of IMUL] may also be used with unsigned operands
587 because the lower half of the product is the same regardless if
588 (sic) the operands are signed or unsigned. The CF and OF flags,
589 however, cannot be used to determine if the upper half of the
590 result is non-zero." So there.
592 pprInstr (AND size src dst) = pprSizeOpOp (sLit "and") size src dst
593 pprInstr (OR size src dst) = pprSizeOpOp (sLit "or") size src dst
595 pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst
596 pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst
597 pprInstr (XOR size src dst) = pprSizeOpOp (sLit "xor") size src dst
599 pprInstr (NOT size op) = pprSizeOp (sLit "not") size op
600 pprInstr (NEGI size op) = pprSizeOp (sLit "neg") size op
602 pprInstr (SHL size src dst) = pprShift (sLit "shl") size src dst
603 pprInstr (SAR size src dst) = pprShift (sLit "sar") size src dst
604 pprInstr (SHR size src dst) = pprShift (sLit "shr") size src dst
606 pprInstr (BT size imm src) = pprSizeImmOp (sLit "bt") size imm src
608 pprInstr (CMP size src dst)
609 | is_float size = pprSizeOpOp (sLit "ucomi") size src dst -- SSE2
610 | otherwise = pprSizeOpOp (sLit "cmp") size src dst
612 -- This predicate is needed here and nowhere else
618 pprInstr (TEST size src dst) = pprSizeOpOp (sLit "test") size src dst
619 pprInstr (PUSH size op) = pprSizeOp (sLit "push") size op
620 pprInstr (POP size op) = pprSizeOp (sLit "pop") size op
622 -- both unused (SDM):
623 -- pprInstr PUSHA = ptext (sLit "\tpushal")
624 -- pprInstr POPA = ptext (sLit "\tpopal")
626 pprInstr NOP = ptext (sLit "\tnop")
627 pprInstr (CLTD II32) = ptext (sLit "\tcltd")
628 pprInstr (CLTD II64) = ptext (sLit "\tcqto")
630 pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op)
632 pprInstr (JXX cond blockid)
633 = pprCondInstr (sLit "j") cond (pprCLabel_asm lab)
634 where lab = mkAsmTempLabel (getUnique blockid)
636 pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm)
638 pprInstr (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm)
639 pprInstr (JMP op) = (<>) (ptext (sLit "\tjmp *")) (pprOperand archWordSize op)
640 pprInstr (JMP_TBL op _) = pprInstr (JMP op)
641 pprInstr (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm)
642 pprInstr (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg archWordSize reg)
644 pprInstr (IDIV sz op) = pprSizeOp (sLit "idiv") sz op
645 pprInstr (DIV sz op) = pprSizeOp (sLit "div") sz op
646 pprInstr (IMUL2 sz op) = pprSizeOp (sLit "imul") sz op
649 pprInstr (MUL size op1 op2) = pprSizeOpOp (sLit "mul") size op1 op2
651 pprInstr (FDIV size op1 op2) = pprSizeOpOp (sLit "div") size op1 op2
653 pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to
654 pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to
655 pprInstr (CVTTSS2SIQ sz from to) = pprSizeOpReg (sLit "cvttss2si") sz from to
656 pprInstr (CVTTSD2SIQ sz from to) = pprSizeOpReg (sLit "cvttsd2si") sz from to
657 pprInstr (CVTSI2SS sz from to) = pprSizeOpReg (sLit "cvtsi2ss") sz from to
658 pprInstr (CVTSI2SD sz from to) = pprSizeOpReg (sLit "cvtsi2sd") sz from to
660 -- FETCHGOT for PIC on ELF platforms
661 pprInstr (FETCHGOT reg)
662 = vcat [ ptext (sLit "\tcall 1f"),
663 hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ],
664 hcat [ ptext (sLit "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "),
668 -- FETCHPC for PIC on Darwin/x86
669 -- get the instruction pointer into a register
670 -- (Terminology note: the IP is called Program Counter on PPC,
671 -- and it's a good thing to use the same name on both platforms)
672 pprInstr (FETCHPC reg)
673 = vcat [ ptext (sLit "\tcall 1f"),
674 hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ]
678 -- -----------------------------------------------------------------------------
679 -- i386 floating-point
681 -- Simulating a flat register set on the x86 FP stack is tricky.
682 -- you have to free %st(7) before pushing anything on the FP reg stack
683 -- so as to preclude the possibility of a FP stack overflow exception.
684 pprInstr g@(GMOV src dst)
688 = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
690 -- GLD sz addr dst ==> FLDsz addr ; FSTP (dst+1)
691 pprInstr g@(GLD sz addr dst)
692 = pprG g (hcat [gtab, text "fld", pprSize_x87 sz, gsp,
693 pprAddr addr, gsemi, gpop dst 1])
695 -- GST sz src addr ==> FLD dst ; FSTPsz addr
696 pprInstr g@(GST sz src addr)
697 | src == fake0 && sz /= FF80 -- fstt instruction doesn't exist
698 = pprG g (hcat [gtab,
699 text "fst", pprSize_x87 sz, gsp, pprAddr addr])
701 = pprG g (hcat [gtab, gpush src 0, gsemi,
702 text "fstp", pprSize_x87 sz, gsp, pprAddr addr])
704 pprInstr g@(GLDZ dst)
705 = pprG g (hcat [gtab, text "fldz ; ", gpop dst 1])
706 pprInstr g@(GLD1 dst)
707 = pprG g (hcat [gtab, text "fld1 ; ", gpop dst 1])
709 pprInstr (GFTOI src dst)
710 = pprInstr (GDTOI src dst)
712 pprInstr g@(GDTOI src dst)
714 hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"],
715 hcat [gtab, gpush src 0],
716 hcat [gtab, text "movzwl 4(%esp), ", reg,
717 text " ; orl $0xC00, ", reg],
718 hcat [gtab, text "movl ", reg, text ", 0(%esp) ; fldcw 0(%esp)"],
719 hcat [gtab, text "fistpl 0(%esp)"],
720 hcat [gtab, text "fldcw 4(%esp) ; movl 0(%esp), ", reg],
721 hcat [gtab, text "addl $8, %esp"]
724 reg = pprReg II32 dst
726 pprInstr (GITOF src dst)
727 = pprInstr (GITOD src dst)
729 pprInstr g@(GITOD src dst)
730 = pprG g (hcat [gtab, text "pushl ", pprReg II32 src,
731 text " ; fildl (%esp) ; ",
732 gpop dst 1, text " ; addl $4,%esp"])
734 pprInstr g@(GDTOF src dst)
735 = pprG g (vcat [gtab <> gpush src 0,
736 gtab <> text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ;",
739 {- Gruesome swamp follows. If you're unfortunate enough to have ventured
740 this far into the jungle AND you give a Rat's Ass (tm) what's going
741 on, here's the deal. Generate code to do a floating point comparison
742 of src1 and src2, of kind cond, and set the Zero flag if true.
744 The complications are to do with handling NaNs correctly. We want the
745 property that if either argument is NaN, then the result of the
746 comparison is False ... except if we're comparing for inequality,
747 in which case the answer is True.
749 Here's how the general (non-inequality) case works. As an
750 example, consider generating the an equality test:
752 pushl %eax -- we need to mess with this
753 <get src1 to top of FPU stack>
754 fcomp <src2 location in FPU stack> and pop pushed src1
755 -- Result of comparison is in FPU Status Register bits
757 fstsw %ax -- Move FPU Status Reg to %ax
758 sahf -- move C3 C2 C0 from %ax to integer flag reg
759 -- now the serious magic begins
760 setpo %ah -- %ah = if comparable(neither arg was NaN) then 1 else 0
761 sete %al -- %al = if arg1 == arg2 then 1 else 0
762 andb %ah,%al -- %al &= %ah
763 -- so %al == 1 iff (comparable && same); else it holds 0
764 decb %al -- %al == 0, ZeroFlag=1 iff (comparable && same);
765 else %al == 0xFF, ZeroFlag=0
766 -- the zero flag is now set as we desire.
769 The special case of inequality differs thusly:
771 setpe %ah -- %ah = if incomparable(either arg was NaN) then 1 else 0
772 setne %al -- %al = if arg1 /= arg2 then 1 else 0
773 orb %ah,%al -- %al = if (incomparable || different) then 1 else 0
774 decb %al -- if (incomparable || different) then (%al == 0, ZF=1)
775 else (%al == 0xFF, ZF=0)
777 pprInstr g@(GCMP cond src1 src2)
778 | case cond of { NE -> True; _ -> False }
780 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
781 hcat [gtab, text "fcomp ", greg src2 1,
782 text "; fstsw %ax ; sahf ; setpe %ah"],
783 hcat [gtab, text "setne %al ; ",
784 text "orb %ah,%al ; decb %al ; popl %eax"]
788 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
789 hcat [gtab, text "fcomp ", greg src2 1,
790 text "; fstsw %ax ; sahf ; setpo %ah"],
791 hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ; ",
792 text "andb %ah,%al ; decb %al ; popl %eax"]
795 {- On the 486, the flags set by FP compare are the unsigned ones!
796 (This looks like a HACK to me. WDP 96/03)
798 fix_FP_cond :: Cond -> Cond
803 fix_FP_cond EQQ = EQQ
805 fix_FP_cond _ = panic "X86.Ppr.fix_FP_cond: no match"
806 -- there should be no others
809 pprInstr g@(GABS _ src dst)
810 = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
812 pprInstr g@(GNEG _ src dst)
813 = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
815 pprInstr g@(GSQRT sz src dst)
816 = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
817 hcat [gtab, gcoerceto sz, gpop dst 1])
819 pprInstr g@(GSIN sz l1 l2 src dst)
820 = pprG g (pprTrigOp "fsin" False l1 l2 src dst sz)
822 pprInstr g@(GCOS sz l1 l2 src dst)
823 = pprG g (pprTrigOp "fcos" False l1 l2 src dst sz)
825 pprInstr g@(GTAN sz l1 l2 src dst)
826 = pprG g (pprTrigOp "fptan" True l1 l2 src dst sz)
828 -- In the translations for GADD, GMUL, GSUB and GDIV,
829 -- the first two cases are mere optimisations. The otherwise clause
830 -- generates correct code under all circumstances.
832 pprInstr g@(GADD _ src1 src2 dst)
834 = pprG g (text "\t#GADD-xxxcase1" $$
835 hcat [gtab, gpush src2 0,
836 text " ; faddp %st(0),", greg src1 1])
838 = pprG g (text "\t#GADD-xxxcase2" $$
839 hcat [gtab, gpush src1 0,
840 text " ; faddp %st(0),", greg src2 1])
842 = pprG g (hcat [gtab, gpush src1 0,
843 text " ; fadd ", greg src2 1, text ",%st(0)",
847 pprInstr g@(GMUL _ src1 src2 dst)
849 = pprG g (text "\t#GMUL-xxxcase1" $$
850 hcat [gtab, gpush src2 0,
851 text " ; fmulp %st(0),", greg src1 1])
853 = pprG g (text "\t#GMUL-xxxcase2" $$
854 hcat [gtab, gpush src1 0,
855 text " ; fmulp %st(0),", greg src2 1])
857 = pprG g (hcat [gtab, gpush src1 0,
858 text " ; fmul ", greg src2 1, text ",%st(0)",
862 pprInstr g@(GSUB _ src1 src2 dst)
864 = pprG g (text "\t#GSUB-xxxcase1" $$
865 hcat [gtab, gpush src2 0,
866 text " ; fsubrp %st(0),", greg src1 1])
868 = pprG g (text "\t#GSUB-xxxcase2" $$
869 hcat [gtab, gpush src1 0,
870 text " ; fsubp %st(0),", greg src2 1])
872 = pprG g (hcat [gtab, gpush src1 0,
873 text " ; fsub ", greg src2 1, text ",%st(0)",
877 pprInstr g@(GDIV _ src1 src2 dst)
879 = pprG g (text "\t#GDIV-xxxcase1" $$
880 hcat [gtab, gpush src2 0,
881 text " ; fdivrp %st(0),", greg src1 1])
883 = pprG g (text "\t#GDIV-xxxcase2" $$
884 hcat [gtab, gpush src1 0,
885 text " ; fdivp %st(0),", greg src2 1])
887 = pprG g (hcat [gtab, gpush src1 0,
888 text " ; fdiv ", greg src2 1, text ",%st(0)",
893 = vcat [ ptext (sLit "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
894 ptext (sLit "\tffree %st(4) ;ffree %st(5)")
898 = panic "X86.Ppr.pprInstr: no match"
901 pprTrigOp :: String -> Bool -> CLabel -> CLabel -> Reg -> Reg -> Size -> Doc
902 pprTrigOp op -- fsin, fcos or fptan
903 isTan -- we need a couple of extra steps if we're doing tan
904 l1 l2 -- internal labels for us to use
906 = -- We'll be needing %eax later on
907 hcat [gtab, text "pushl %eax;"] $$
908 -- tan is going to use an extra space on the FP stack
909 (if isTan then hcat [gtab, text "ffree %st(6)"] else empty) $$
910 -- First put the value in %st(0) and try to apply the op to it
911 hcat [gpush src 0, text ("; " ++ op)] $$
912 -- Now look to see if C2 was set (overflow, |value| >= 2^63)
913 hcat [gtab, text "fnstsw %ax"] $$
914 hcat [gtab, text "test $0x400,%eax"] $$
915 -- If we were in bounds then jump to the end
916 hcat [gtab, text "je " <> pprCLabel_asm l1] $$
917 -- Otherwise we need to shrink the value. Start by
918 -- loading pi, doubleing it (by adding it to itself),
919 -- and then swapping pi with the value, so the value we
920 -- want to apply op to is in %st(0) again
921 hcat [gtab, text "ffree %st(7); fldpi"] $$
922 hcat [gtab, text "fadd %st(0),%st"] $$
923 hcat [gtab, text "fxch %st(1)"] $$
924 -- Now we have a loop in which we make the value smaller,
925 -- see if it's small enough, and loop if not
926 (pprCLabel_asm l2 <> char ':') $$
927 hcat [gtab, text "fprem1"] $$
928 -- My Debian libc uses fstsw here for the tan code, but I can't
929 -- see any reason why it should need to be different for tan.
930 hcat [gtab, text "fnstsw %ax"] $$
931 hcat [gtab, text "test $0x400,%eax"] $$
932 hcat [gtab, text "jne " <> pprCLabel_asm l2] $$
933 hcat [gtab, text "fstp %st(1)"] $$
934 hcat [gtab, text op] $$
935 (pprCLabel_asm l1 <> char ':') $$
936 -- Pop the 1.0 tan gave us
937 (if isTan then hcat [gtab, text "fstp %st(0)"] else empty) $$
939 hcat [gtab, text "popl %eax;"] $$
940 -- And finally make the result the right size
941 hcat [gtab, gcoerceto sz, gpop dst 1]
943 --------------------------
945 -- coerce %st(0) to the specified size
946 gcoerceto :: Size -> Doc
947 gcoerceto FF64 = empty
948 gcoerceto FF32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
949 gcoerceto _ = panic "X86.Ppr.gcoerceto: no match"
951 gpush :: Reg -> RegNo -> Doc
953 = hcat [text "fld ", greg reg offset]
955 gpop :: Reg -> RegNo -> Doc
957 = hcat [text "fstp ", greg reg offset]
959 greg :: Reg -> RegNo -> Doc
960 greg reg offset = text "%st(" <> int (gregno reg - firstfake+offset) <> char ')'
971 gregno :: Reg -> RegNo
972 gregno (RegReal (RealRegSingle i)) = i
973 gregno _ = --pprPanic "gregno" (ppr other)
974 999 -- bogus; only needed for debug printing
976 pprG :: Instr -> Doc -> Doc
978 = (char '#' <> pprGInstr fake) $$ actual
981 pprGInstr :: Instr -> Doc
982 pprGInstr (GMOV src dst) = pprSizeRegReg (sLit "gmov") FF64 src dst
983 pprGInstr (GLD sz src dst) = pprSizeAddrReg (sLit "gld") sz src dst
984 pprGInstr (GST sz src dst) = pprSizeRegAddr (sLit "gst") sz src dst
986 pprGInstr (GLDZ dst) = pprSizeReg (sLit "gldz") FF64 dst
987 pprGInstr (GLD1 dst) = pprSizeReg (sLit "gld1") FF64 dst
989 pprGInstr (GFTOI src dst) = pprSizeSizeRegReg (sLit "gftoi") FF32 II32 src dst
990 pprGInstr (GDTOI src dst) = pprSizeSizeRegReg (sLit "gdtoi") FF64 II32 src dst
992 pprGInstr (GITOF src dst) = pprSizeSizeRegReg (sLit "gitof") II32 FF32 src dst
993 pprGInstr (GITOD src dst) = pprSizeSizeRegReg (sLit "gitod") II32 FF64 src dst
994 pprGInstr (GDTOF src dst) = pprSizeSizeRegReg (sLit "gdtof") FF64 FF32 src dst
996 pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 co src dst
997 pprGInstr (GABS sz src dst) = pprSizeRegReg (sLit "gabs") sz src dst
998 pprGInstr (GNEG sz src dst) = pprSizeRegReg (sLit "gneg") sz src dst
999 pprGInstr (GSQRT sz src dst) = pprSizeRegReg (sLit "gsqrt") sz src dst
1000 pprGInstr (GSIN sz _ _ src dst) = pprSizeRegReg (sLit "gsin") sz src dst
1001 pprGInstr (GCOS sz _ _ src dst) = pprSizeRegReg (sLit "gcos") sz src dst
1002 pprGInstr (GTAN sz _ _ src dst) = pprSizeRegReg (sLit "gtan") sz src dst
1004 pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg (sLit "gadd") sz src1 src2 dst
1005 pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg (sLit "gsub") sz src1 src2 dst
1006 pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg (sLit "gmul") sz src1 src2 dst
1007 pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg (sLit "gdiv") sz src1 src2 dst
1009 pprGInstr _ = panic "X86.Ppr.pprGInstr: no match"
1011 pprDollImm :: Imm -> Doc
1012 pprDollImm i = ptext (sLit "$") <> pprImm i
1015 pprOperand :: Size -> Operand -> Doc
1016 pprOperand s (OpReg r) = pprReg s r
1017 pprOperand _ (OpImm i) = pprDollImm i
1018 pprOperand _ (OpAddr ea) = pprAddr ea
1021 pprMnemonic_ :: LitString -> Doc
1023 char '\t' <> ptext name <> space
1026 pprMnemonic :: LitString -> Size -> Doc
1027 pprMnemonic name size =
1028 char '\t' <> ptext name <> pprSize size <> space
1031 pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc
1032 pprSizeImmOp name size imm op1
1034 pprMnemonic name size,
1042 pprSizeOp :: LitString -> Size -> Operand -> Doc
1043 pprSizeOp name size op1
1045 pprMnemonic name size,
1050 pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1051 pprSizeOpOp name size op1 op2
1053 pprMnemonic name size,
1054 pprOperand size op1,
1060 pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1061 pprOpOp name size op1 op2
1064 pprOperand size op1,
1070 pprSizeReg :: LitString -> Size -> Reg -> Doc
1071 pprSizeReg name size reg1
1073 pprMnemonic name size,
1078 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
1079 pprSizeRegReg name size reg1 reg2
1081 pprMnemonic name size,
1088 pprRegReg :: LitString -> Reg -> Reg -> Doc
1089 pprRegReg name reg1 reg2
1092 pprReg archWordSize reg1,
1094 pprReg archWordSize reg2
1098 pprSizeOpReg :: LitString -> Size -> Operand -> Reg -> Doc
1099 pprSizeOpReg name size op1 reg2
1101 pprMnemonic name size,
1102 pprOperand size op1,
1104 pprReg archWordSize reg2
1108 pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc
1109 pprCondRegReg name size cond reg1 reg2
1120 pprSizeSizeRegReg :: LitString -> Size -> Size -> Reg -> Reg -> Doc
1121 pprSizeSizeRegReg name size1 size2 reg1 reg2
1135 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1136 pprSizeRegRegReg name size reg1 reg2 reg3
1138 pprMnemonic name size,
1147 pprSizeAddrReg :: LitString -> Size -> AddrMode -> Reg -> Doc
1148 pprSizeAddrReg name size op dst
1150 pprMnemonic name size,
1157 pprSizeRegAddr :: LitString -> Size -> Reg -> AddrMode -> Doc
1158 pprSizeRegAddr name size src op
1160 pprMnemonic name size,
1167 pprShift :: LitString -> Size -> Operand -> Operand -> Doc
1168 pprShift name size src dest
1170 pprMnemonic name size,
1171 pprOperand II8 src, -- src is 8-bit sized
1173 pprOperand size dest
1177 pprSizeOpOpCoerce :: LitString -> Size -> Size -> Operand -> Operand -> Doc
1178 pprSizeOpOpCoerce name size1 size2 op1 op2
1179 = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
1180 pprOperand size1 op1,
1182 pprOperand size2 op2
1186 pprCondInstr :: LitString -> Cond -> Doc -> Doc
1187 pprCondInstr name cond arg
1188 = hcat [ char '\t', ptext name, pprCond cond, space, arg]