1 -----------------------------------------------------------------------------
3 -- Pretty-printing assembly language
5 -- (c) The University of Glasgow 1993-2005
7 -----------------------------------------------------------------------------
22 #include "HsVersions.h"
23 #include "nativeGen/NCG.h"
36 import Unique ( pprUnique, Uniquable(..) )
39 import qualified Outputable
40 import Outputable (panic, Outputable)
44 #if i386_TARGET_ARCH && darwin_TARGET_OS
48 -- -----------------------------------------------------------------------------
49 -- Printing this stuff out
51 pprNatCmmTop :: NatCmmTop Instr -> Doc
52 pprNatCmmTop (CmmData section dats) =
53 pprSectionHeader section $$ vcat (map pprData dats)
55 -- special case for split markers:
56 pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl
58 pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) =
59 pprSectionHeader Text $$
60 (if null info then -- blocks guaranteed not null, so label needed
63 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
64 pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
67 vcat (map pprData info) $$
68 pprLabel (entryLblToInfoLbl lbl)
70 vcat (map pprBasicBlock blocks)
71 -- above: Even the first block gets a label, because with branch-chain
72 -- elimination, it might be the target of a goto.
73 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
74 -- If we are using the .subsections_via_symbols directive
75 -- (available on recent versions of Darwin),
76 -- we have to make sure that there is some kind of reference
77 -- from the entry code to a label on the _top_ of of the info table,
78 -- so that the linker will not think it is unreferenced and dead-strip
79 -- it. That's why the label is called a DeadStripPreventer (_dsp).
82 <+> pprCLabel_asm (entryLblToInfoLbl lbl)
84 <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
87 $$ pprSizeDecl (if null info then lbl else entryLblToInfoLbl lbl)
89 -- | Output the ELF .size directive.
90 pprSizeDecl :: CLabel -> Doc
93 ptext (sLit "\t.size") <+> pprCLabel_asm lbl
94 <> ptext (sLit ", .-") <> pprCLabel_asm lbl
99 pprBasicBlock :: NatBasicBlock Instr -> Doc
100 pprBasicBlock (BasicBlock blockid instrs) =
101 pprLabel (mkAsmTempLabel (getUnique blockid)) $$
102 vcat (map pprInstr instrs)
105 pprData :: CmmStatic -> Doc
106 pprData (CmmAlign bytes) = pprAlign bytes
107 pprData (CmmDataLabel lbl) = pprLabel lbl
108 pprData (CmmString str) = pprASCII str
111 pprData (CmmUninitialised bytes) = ptext (sLit ".space ") <> int bytes
113 pprData (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes
116 pprData (CmmStaticLit lit) = pprDataItem lit
118 pprGloblDecl :: CLabel -> Doc
120 | not (externallyVisibleCLabel lbl) = empty
121 | otherwise = ptext (sLit ".globl ") <> pprCLabel_asm lbl
123 pprTypeAndSizeDecl :: CLabel -> Doc
125 pprTypeAndSizeDecl lbl
126 | not (externallyVisibleCLabel lbl) = empty
127 | otherwise = ptext (sLit ".type ") <>
128 pprCLabel_asm lbl <> ptext (sLit ", @object")
134 pprLabel :: CLabel -> Doc
135 pprLabel lbl = pprGloblDecl lbl $$ pprTypeAndSizeDecl lbl $$ (pprCLabel_asm lbl <> char ':')
138 pprASCII :: [Word8] -> Doc
140 = vcat (map do1 str) $$ do1 0
143 do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w)
145 pprAlign :: Int -> Doc
149 = ptext (sLit ".align ") <> int IF_OS_darwin(pow2, bytes)
155 log2 :: Int -> Int -- cache the common ones
160 log2 n = 1 + log2 (n `quot` 2)
163 -- -----------------------------------------------------------------------------
164 -- pprInstr: print an 'Instr'
166 instance Outputable Instr where
167 ppr instr = Outputable.docToSDoc $ pprInstr instr
170 pprReg :: Size -> Reg -> Doc
174 RegReal (RealRegSingle i) -> ppr_reg_no s i
175 RegReal (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch"
176 RegVirtual (VirtualRegI u) -> text "%vI_" <> asmSDoc (pprUnique u)
177 RegVirtual (VirtualRegHi u) -> text "%vHi_" <> asmSDoc (pprUnique u)
178 RegVirtual (VirtualRegF u) -> text "%vF_" <> asmSDoc (pprUnique u)
179 RegVirtual (VirtualRegD u) -> text "%vD_" <> asmSDoc (pprUnique u)
180 RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> asmSDoc (pprUnique u)
183 ppr_reg_no :: Size -> Int -> Doc
184 ppr_reg_no II8 = ppr_reg_byte
185 ppr_reg_no II16 = ppr_reg_word
186 ppr_reg_no _ = ppr_reg_long
188 ppr_reg_byte i = ptext
190 0 -> sLit "%al"; 1 -> sLit "%bl";
191 2 -> sLit "%cl"; 3 -> sLit "%dl";
192 _ -> sLit "very naughty I386 byte register"
195 ppr_reg_word i = ptext
197 0 -> sLit "%ax"; 1 -> sLit "%bx";
198 2 -> sLit "%cx"; 3 -> sLit "%dx";
199 4 -> sLit "%si"; 5 -> sLit "%di";
200 6 -> sLit "%bp"; 7 -> sLit "%sp";
201 _ -> sLit "very naughty I386 word register"
204 ppr_reg_long i = ptext
206 0 -> sLit "%eax"; 1 -> sLit "%ebx";
207 2 -> sLit "%ecx"; 3 -> sLit "%edx";
208 4 -> sLit "%esi"; 5 -> sLit "%edi";
209 6 -> sLit "%ebp"; 7 -> sLit "%esp";
212 #elif x86_64_TARGET_ARCH
213 ppr_reg_no :: Size -> Int -> Doc
214 ppr_reg_no II8 = ppr_reg_byte
215 ppr_reg_no II16 = ppr_reg_word
216 ppr_reg_no II32 = ppr_reg_long
217 ppr_reg_no _ = ppr_reg_quad
219 ppr_reg_byte i = ptext
221 0 -> sLit "%al"; 1 -> sLit "%bl";
222 2 -> sLit "%cl"; 3 -> sLit "%dl";
223 4 -> sLit "%sil"; 5 -> sLit "%dil"; -- new 8-bit regs!
224 6 -> sLit "%bpl"; 7 -> sLit "%spl";
225 8 -> sLit "%r8b"; 9 -> sLit "%r9b";
226 10 -> sLit "%r10b"; 11 -> sLit "%r11b";
227 12 -> sLit "%r12b"; 13 -> sLit "%r13b";
228 14 -> sLit "%r14b"; 15 -> sLit "%r15b";
229 _ -> sLit "very naughty x86_64 byte register"
232 ppr_reg_word i = ptext
234 0 -> sLit "%ax"; 1 -> sLit "%bx";
235 2 -> sLit "%cx"; 3 -> sLit "%dx";
236 4 -> sLit "%si"; 5 -> sLit "%di";
237 6 -> sLit "%bp"; 7 -> sLit "%sp";
238 8 -> sLit "%r8w"; 9 -> sLit "%r9w";
239 10 -> sLit "%r10w"; 11 -> sLit "%r11w";
240 12 -> sLit "%r12w"; 13 -> sLit "%r13w";
241 14 -> sLit "%r14w"; 15 -> sLit "%r15w";
242 _ -> sLit "very naughty x86_64 word register"
245 ppr_reg_long i = ptext
247 0 -> sLit "%eax"; 1 -> sLit "%ebx";
248 2 -> sLit "%ecx"; 3 -> sLit "%edx";
249 4 -> sLit "%esi"; 5 -> sLit "%edi";
250 6 -> sLit "%ebp"; 7 -> sLit "%esp";
251 8 -> sLit "%r8d"; 9 -> sLit "%r9d";
252 10 -> sLit "%r10d"; 11 -> sLit "%r11d";
253 12 -> sLit "%r12d"; 13 -> sLit "%r13d";
254 14 -> sLit "%r14d"; 15 -> sLit "%r15d";
255 _ -> sLit "very naughty x86_64 register"
258 ppr_reg_quad i = ptext
260 0 -> sLit "%rax"; 1 -> sLit "%rbx";
261 2 -> sLit "%rcx"; 3 -> sLit "%rdx";
262 4 -> sLit "%rsi"; 5 -> sLit "%rdi";
263 6 -> sLit "%rbp"; 7 -> sLit "%rsp";
264 8 -> sLit "%r8"; 9 -> sLit "%r9";
265 10 -> sLit "%r10"; 11 -> sLit "%r11";
266 12 -> sLit "%r12"; 13 -> sLit "%r13";
267 14 -> sLit "%r14"; 15 -> sLit "%r15";
271 ppr_reg_no _ = panic "X86.Ppr.ppr_reg_no: no match"
274 #if defined(i386_TARGET_ARCH) || defined(x86_64_TARGET_ARCH)
275 ppr_reg_float :: Int -> LitString
276 ppr_reg_float i = case i of
277 16 -> sLit "%fake0"; 17 -> sLit "%fake1"
278 18 -> sLit "%fake2"; 19 -> sLit "%fake3"
279 20 -> sLit "%fake4"; 21 -> sLit "%fake5"
280 24 -> sLit "%xmm0"; 25 -> sLit "%xmm1"
281 26 -> sLit "%xmm2"; 27 -> sLit "%xmm3"
282 28 -> sLit "%xmm4"; 29 -> sLit "%xmm5"
283 30 -> sLit "%xmm6"; 31 -> sLit "%xmm7"
284 32 -> sLit "%xmm8"; 33 -> sLit "%xmm9"
285 34 -> sLit "%xmm10"; 35 -> sLit "%xmm11"
286 36 -> sLit "%xmm12"; 37 -> sLit "%xmm13"
287 38 -> sLit "%xmm14"; 39 -> sLit "%xmm15"
288 _ -> sLit "very naughty x86 register"
291 pprSize :: Size -> Doc
298 FF32 -> sLit "ss" -- "scalar single-precision float" (SSE2)
299 FF64 -> sLit "sd" -- "scalar double-precision float" (SSE2)
303 pprSize_x87 :: Size -> Doc
309 _ -> panic "X86.Ppr.pprSize_x87"
311 pprCond :: Cond -> Doc
314 GEU -> sLit "ae"; LU -> sLit "b";
315 EQQ -> sLit "e"; GTT -> sLit "g";
316 GE -> sLit "ge"; GU -> sLit "a";
317 LTT -> sLit "l"; LE -> sLit "le";
318 LEU -> sLit "be"; NE -> sLit "ne";
319 NEG -> sLit "s"; POS -> sLit "ns";
320 CARRY -> sLit "c"; OFLO -> sLit "o";
321 PARITY -> sLit "p"; NOTPARITY -> sLit "np";
322 ALWAYS -> sLit "mp"})
326 pprImm (ImmInt i) = int i
327 pprImm (ImmInteger i) = integer i
328 pprImm (ImmCLbl l) = pprCLabel_asm l
329 pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i
330 pprImm (ImmLit s) = s
332 pprImm (ImmFloat _) = ptext (sLit "naughty float immediate")
333 pprImm (ImmDouble _) = ptext (sLit "naughty double immediate")
335 pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
336 pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
337 <> lparen <> pprImm b <> rparen
341 pprAddr :: AddrMode -> Doc
342 pprAddr (ImmAddr imm off)
343 = let pp_imm = pprImm imm
347 else if (off < 0) then
350 pp_imm <> char '+' <> int off
352 pprAddr (AddrBaseIndex base index displacement)
354 pp_disp = ppr_disp displacement
355 pp_off p = pp_disp <> char '(' <> p <> char ')'
356 pp_reg r = pprReg archWordSize r
358 case (base, index) of
359 (EABaseNone, EAIndexNone) -> pp_disp
360 (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b)
361 (EABaseRip, EAIndexNone) -> pp_off (ptext (sLit "%rip"))
362 (EABaseNone, EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i)
363 (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r
365 _ -> panic "X86.Ppr.pprAddr: no match"
368 ppr_disp (ImmInt 0) = empty
369 ppr_disp imm = pprImm imm
372 pprSectionHeader :: Section -> Doc
375 # if darwin_TARGET_OS
378 Text -> ptext (sLit ".text\n\t.align 2")
379 Data -> ptext (sLit ".data\n\t.align 2")
380 ReadOnlyData -> ptext (sLit ".const\n.align 2")
381 RelocatableReadOnlyData -> ptext (sLit ".const_data\n.align 2")
382 UninitialisedData -> ptext (sLit ".data\n\t.align 2")
383 ReadOnlyData16 -> ptext (sLit ".const\n.align 4")
384 OtherSection _ -> panic "X86.Ppr.pprSectionHeader: unknown section"
389 Text -> ptext (sLit ".text\n\t.align 4,0x90")
390 Data -> ptext (sLit ".data\n\t.align 4")
391 ReadOnlyData -> ptext (sLit ".section .rodata\n\t.align 4")
392 RelocatableReadOnlyData -> ptext (sLit ".section .data\n\t.align 4")
393 UninitialisedData -> ptext (sLit ".section .bss\n\t.align 4")
394 ReadOnlyData16 -> ptext (sLit ".section .rodata\n\t.align 16")
395 OtherSection _ -> panic "X86.Ppr.pprSectionHeader: unknown section"
399 #elif x86_64_TARGET_ARCH
400 # if darwin_TARGET_OS
403 Text -> ptext (sLit ".text\n.align 3")
404 Data -> ptext (sLit ".data\n.align 3")
405 ReadOnlyData -> ptext (sLit ".const\n.align 3")
406 RelocatableReadOnlyData -> ptext (sLit ".const_data\n.align 3")
407 UninitialisedData -> ptext (sLit ".data\n\t.align 3")
408 ReadOnlyData16 -> ptext (sLit ".const\n.align 4")
409 OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section"
414 Text -> ptext (sLit ".text\n\t.align 8")
415 Data -> ptext (sLit ".data\n\t.align 8")
416 ReadOnlyData -> ptext (sLit ".section .rodata\n\t.align 8")
417 RelocatableReadOnlyData -> ptext (sLit ".section .data\n\t.align 8")
418 UninitialisedData -> ptext (sLit ".section .bss\n\t.align 8")
419 ReadOnlyData16 -> ptext (sLit ".section .rodata.cst16\n\t.align 16")
420 OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section"
425 pprSectionHeader _ = panic "X86.Ppr.pprSectionHeader: not defined for this architecture"
432 pprDataItem :: CmmLit -> Doc
434 = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit)
438 -- These seem to be common:
439 ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm imm]
440 ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm imm]
442 ppr_item FF32 (CmmFloat r _)
443 = let bs = floatToBytes (fromRational r)
444 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
446 ppr_item FF64 (CmmFloat r _)
447 = let bs = doubleToBytes (fromRational r)
448 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
450 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
451 ppr_item II16 _ = [ptext (sLit "\t.word\t") <> pprImm imm]
453 #if i386_TARGET_ARCH && darwin_TARGET_OS
454 ppr_item II64 (CmmInt x _) =
455 [ptext (sLit "\t.long\t")
456 <> int (fromIntegral (fromIntegral x :: Word32)),
457 ptext (sLit "\t.long\t")
459 (fromIntegral (x `shiftR` 32) :: Word32))]
461 #if i386_TARGET_ARCH || (darwin_TARGET_OS && x86_64_TARGET_ARCH)
462 ppr_item II64 _ = [ptext (sLit "\t.quad\t") <> pprImm imm]
464 #if x86_64_TARGET_ARCH && !darwin_TARGET_OS
465 -- x86_64: binutils can't handle the R_X86_64_PC64 relocation
466 -- type, which means we can't do pc-relative 64-bit addresses.
467 -- Fortunately we're assuming the small memory model, in which
468 -- all such offsets will fit into 32 bits, so we have to stick
469 -- to 32-bit offset fields and modify the RTS appropriately
471 -- See Note [x86-64-relative] in includes/rts/storage/InfoTables.h
474 | isRelativeReloc x =
475 [ptext (sLit "\t.long\t") <> pprImm imm,
476 ptext (sLit "\t.long\t0")]
478 [ptext (sLit "\t.quad\t") <> pprImm imm]
480 isRelativeReloc (CmmLabelDiffOff _ _ _) = True
481 isRelativeReloc _ = False
485 = panic "X86.Ppr.ppr_item: no match"
489 pprInstr :: Instr -> Doc
491 pprInstr (COMMENT _) = empty -- nuke 'em
493 pprInstr (COMMENT s) = ptext (sLit "# ") <> ftext s
496 = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
498 pprInstr (NEWBLOCK _)
499 = panic "PprMach.pprInstr: NEWBLOCK"
502 = panic "PprMach.pprInstr: LDATA"
505 pprInstr (SPILL reg slot)
507 ptext (sLit "\tSPILL"),
511 ptext (sLit "SLOT") <> parens (int slot)]
513 pprInstr (RELOAD slot reg)
515 ptext (sLit "\tRELOAD"),
517 ptext (sLit "SLOT") <> parens (int slot),
522 pprInstr (MOV size src dst)
523 = pprSizeOpOp (sLit "mov") size src dst
525 pprInstr (MOVZxL II32 src dst) = pprSizeOpOp (sLit "mov") II32 src dst
526 -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple
527 -- movl. But we represent it as a MOVZxL instruction, because
528 -- the reg alloc would tend to throw away a plain reg-to-reg
529 -- move, and we still want it to do that.
531 pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce (sLit "movz") sizes II32 src dst
532 -- zero-extension only needs to extend to 32 bits: on x86_64,
533 -- the remaining zero-extension to 64 bits is automatic, and the 32-bit
534 -- instruction is shorter.
536 pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce (sLit "movs") sizes archWordSize src dst
538 -- here we do some patching, since the physical registers are only set late
539 -- in the code generation.
540 pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
542 = pprSizeOpOp (sLit "add") size (OpReg reg2) dst
544 pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
546 = pprSizeOpOp (sLit "add") size (OpReg reg1) dst
548 pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))
550 = pprInstr (ADD size (OpImm displ) dst)
552 pprInstr (LEA size src dst) = pprSizeOpOp (sLit "lea") size src dst
554 pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
555 = pprSizeOp (sLit "dec") size dst
556 pprInstr (ADD size (OpImm (ImmInt 1)) dst)
557 = pprSizeOp (sLit "inc") size dst
558 pprInstr (ADD size src dst)
559 = pprSizeOpOp (sLit "add") size src dst
560 pprInstr (ADC size src dst)
561 = pprSizeOpOp (sLit "adc") size src dst
562 pprInstr (SUB size src dst) = pprSizeOpOp (sLit "sub") size src dst
563 pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2
565 {- A hack. The Intel documentation says that "The two and three
566 operand forms [of IMUL] may also be used with unsigned operands
567 because the lower half of the product is the same regardless if
568 (sic) the operands are signed or unsigned. The CF and OF flags,
569 however, cannot be used to determine if the upper half of the
570 result is non-zero." So there.
572 pprInstr (AND size src dst) = pprSizeOpOp (sLit "and") size src dst
573 pprInstr (OR size src dst) = pprSizeOpOp (sLit "or") size src dst
575 pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst
576 pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst
577 pprInstr (XOR size src dst) = pprSizeOpOp (sLit "xor") size src dst
579 pprInstr (NOT size op) = pprSizeOp (sLit "not") size op
580 pprInstr (NEGI size op) = pprSizeOp (sLit "neg") size op
582 pprInstr (SHL size src dst) = pprShift (sLit "shl") size src dst
583 pprInstr (SAR size src dst) = pprShift (sLit "sar") size src dst
584 pprInstr (SHR size src dst) = pprShift (sLit "shr") size src dst
586 pprInstr (BT size imm src) = pprSizeImmOp (sLit "bt") size imm src
588 pprInstr (CMP size src dst)
589 | is_float size = pprSizeOpOp (sLit "ucomi") size src dst -- SSE2
590 | otherwise = pprSizeOpOp (sLit "cmp") size src dst
592 -- This predicate is needed here and nowhere else
598 pprInstr (TEST size src dst) = pprSizeOpOp (sLit "test") size src dst
599 pprInstr (PUSH size op) = pprSizeOp (sLit "push") size op
600 pprInstr (POP size op) = pprSizeOp (sLit "pop") size op
602 -- both unused (SDM):
603 -- pprInstr PUSHA = ptext (sLit "\tpushal")
604 -- pprInstr POPA = ptext (sLit "\tpopal")
606 pprInstr NOP = ptext (sLit "\tnop")
607 pprInstr (CLTD II32) = ptext (sLit "\tcltd")
608 pprInstr (CLTD II64) = ptext (sLit "\tcqto")
610 pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op)
612 pprInstr (JXX cond blockid)
613 = pprCondInstr (sLit "j") cond (pprCLabel_asm lab)
614 where lab = mkAsmTempLabel (getUnique blockid)
616 pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm)
618 pprInstr (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm)
619 pprInstr (JMP op) = (<>) (ptext (sLit "\tjmp *")) (pprOperand archWordSize op)
620 pprInstr (JMP_TBL op _ _ _) = pprInstr (JMP op)
621 pprInstr (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm)
622 pprInstr (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg archWordSize reg)
624 pprInstr (IDIV sz op) = pprSizeOp (sLit "idiv") sz op
625 pprInstr (DIV sz op) = pprSizeOp (sLit "div") sz op
626 pprInstr (IMUL2 sz op) = pprSizeOp (sLit "imul") sz op
629 pprInstr (MUL size op1 op2) = pprSizeOpOp (sLit "mul") size op1 op2
631 pprInstr (FDIV size op1 op2) = pprSizeOpOp (sLit "div") size op1 op2
633 pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to
634 pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to
635 pprInstr (CVTTSS2SIQ sz from to) = pprSizeSizeOpReg (sLit "cvttss2si") FF32 sz from to
636 pprInstr (CVTTSD2SIQ sz from to) = pprSizeSizeOpReg (sLit "cvttsd2si") FF64 sz from to
637 pprInstr (CVTSI2SS sz from to) = pprSizeOpReg (sLit "cvtsi2ss") sz from to
638 pprInstr (CVTSI2SD sz from to) = pprSizeOpReg (sLit "cvtsi2sd") sz from to
640 -- FETCHGOT for PIC on ELF platforms
641 pprInstr (FETCHGOT reg)
642 = vcat [ ptext (sLit "\tcall 1f"),
643 hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ],
644 hcat [ ptext (sLit "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "),
648 -- FETCHPC for PIC on Darwin/x86
649 -- get the instruction pointer into a register
650 -- (Terminology note: the IP is called Program Counter on PPC,
651 -- and it's a good thing to use the same name on both platforms)
652 pprInstr (FETCHPC reg)
653 = vcat [ ptext (sLit "\tcall 1f"),
654 hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ]
658 -- -----------------------------------------------------------------------------
659 -- i386 floating-point
661 -- Simulating a flat register set on the x86 FP stack is tricky.
662 -- you have to free %st(7) before pushing anything on the FP reg stack
663 -- so as to preclude the possibility of a FP stack overflow exception.
664 pprInstr g@(GMOV src dst)
668 = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
670 -- GLD sz addr dst ==> FLDsz addr ; FSTP (dst+1)
671 pprInstr g@(GLD sz addr dst)
672 = pprG g (hcat [gtab, text "fld", pprSize_x87 sz, gsp,
673 pprAddr addr, gsemi, gpop dst 1])
675 -- GST sz src addr ==> FLD dst ; FSTPsz addr
676 pprInstr g@(GST sz src addr)
677 | src == fake0 && sz /= FF80 -- fstt instruction doesn't exist
678 = pprG g (hcat [gtab,
679 text "fst", pprSize_x87 sz, gsp, pprAddr addr])
681 = pprG g (hcat [gtab, gpush src 0, gsemi,
682 text "fstp", pprSize_x87 sz, gsp, pprAddr addr])
684 pprInstr g@(GLDZ dst)
685 = pprG g (hcat [gtab, text "fldz ; ", gpop dst 1])
686 pprInstr g@(GLD1 dst)
687 = pprG g (hcat [gtab, text "fld1 ; ", gpop dst 1])
689 pprInstr (GFTOI src dst)
690 = pprInstr (GDTOI src dst)
692 pprInstr g@(GDTOI src dst)
694 hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"],
695 hcat [gtab, gpush src 0],
696 hcat [gtab, text "movzwl 4(%esp), ", reg,
697 text " ; orl $0xC00, ", reg],
698 hcat [gtab, text "movl ", reg, text ", 0(%esp) ; fldcw 0(%esp)"],
699 hcat [gtab, text "fistpl 0(%esp)"],
700 hcat [gtab, text "fldcw 4(%esp) ; movl 0(%esp), ", reg],
701 hcat [gtab, text "addl $8, %esp"]
704 reg = pprReg II32 dst
706 pprInstr (GITOF src dst)
707 = pprInstr (GITOD src dst)
709 pprInstr g@(GITOD src dst)
710 = pprG g (hcat [gtab, text "pushl ", pprReg II32 src,
711 text " ; fildl (%esp) ; ",
712 gpop dst 1, text " ; addl $4,%esp"])
714 pprInstr g@(GDTOF src dst)
715 = pprG g (vcat [gtab <> gpush src 0,
716 gtab <> text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ;",
719 {- Gruesome swamp follows. If you're unfortunate enough to have ventured
720 this far into the jungle AND you give a Rat's Ass (tm) what's going
721 on, here's the deal. Generate code to do a floating point comparison
722 of src1 and src2, of kind cond, and set the Zero flag if true.
724 The complications are to do with handling NaNs correctly. We want the
725 property that if either argument is NaN, then the result of the
726 comparison is False ... except if we're comparing for inequality,
727 in which case the answer is True.
729 Here's how the general (non-inequality) case works. As an
730 example, consider generating the an equality test:
732 pushl %eax -- we need to mess with this
733 <get src1 to top of FPU stack>
734 fcomp <src2 location in FPU stack> and pop pushed src1
735 -- Result of comparison is in FPU Status Register bits
737 fstsw %ax -- Move FPU Status Reg to %ax
738 sahf -- move C3 C2 C0 from %ax to integer flag reg
739 -- now the serious magic begins
740 setpo %ah -- %ah = if comparable(neither arg was NaN) then 1 else 0
741 sete %al -- %al = if arg1 == arg2 then 1 else 0
742 andb %ah,%al -- %al &= %ah
743 -- so %al == 1 iff (comparable && same); else it holds 0
744 decb %al -- %al == 0, ZeroFlag=1 iff (comparable && same);
745 else %al == 0xFF, ZeroFlag=0
746 -- the zero flag is now set as we desire.
749 The special case of inequality differs thusly:
751 setpe %ah -- %ah = if incomparable(either arg was NaN) then 1 else 0
752 setne %al -- %al = if arg1 /= arg2 then 1 else 0
753 orb %ah,%al -- %al = if (incomparable || different) then 1 else 0
754 decb %al -- if (incomparable || different) then (%al == 0, ZF=1)
755 else (%al == 0xFF, ZF=0)
757 pprInstr g@(GCMP cond src1 src2)
758 | case cond of { NE -> True; _ -> False }
760 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
761 hcat [gtab, text "fcomp ", greg src2 1,
762 text "; fstsw %ax ; sahf ; setpe %ah"],
763 hcat [gtab, text "setne %al ; ",
764 text "orb %ah,%al ; decb %al ; popl %eax"]
768 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
769 hcat [gtab, text "fcomp ", greg src2 1,
770 text "; fstsw %ax ; sahf ; setpo %ah"],
771 hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ; ",
772 text "andb %ah,%al ; decb %al ; popl %eax"]
775 {- On the 486, the flags set by FP compare are the unsigned ones!
776 (This looks like a HACK to me. WDP 96/03)
778 fix_FP_cond :: Cond -> Cond
783 fix_FP_cond EQQ = EQQ
785 fix_FP_cond _ = panic "X86.Ppr.fix_FP_cond: no match"
786 -- there should be no others
789 pprInstr g@(GABS _ src dst)
790 = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
792 pprInstr g@(GNEG _ src dst)
793 = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
795 pprInstr g@(GSQRT sz src dst)
796 = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
797 hcat [gtab, gcoerceto sz, gpop dst 1])
799 pprInstr g@(GSIN sz l1 l2 src dst)
800 = pprG g (pprTrigOp "fsin" False l1 l2 src dst sz)
802 pprInstr g@(GCOS sz l1 l2 src dst)
803 = pprG g (pprTrigOp "fcos" False l1 l2 src dst sz)
805 pprInstr g@(GTAN sz l1 l2 src dst)
806 = pprG g (pprTrigOp "fptan" True l1 l2 src dst sz)
808 -- In the translations for GADD, GMUL, GSUB and GDIV,
809 -- the first two cases are mere optimisations. The otherwise clause
810 -- generates correct code under all circumstances.
812 pprInstr g@(GADD _ src1 src2 dst)
814 = pprG g (text "\t#GADD-xxxcase1" $$
815 hcat [gtab, gpush src2 0,
816 text " ; faddp %st(0),", greg src1 1])
818 = pprG g (text "\t#GADD-xxxcase2" $$
819 hcat [gtab, gpush src1 0,
820 text " ; faddp %st(0),", greg src2 1])
822 = pprG g (hcat [gtab, gpush src1 0,
823 text " ; fadd ", greg src2 1, text ",%st(0)",
827 pprInstr g@(GMUL _ src1 src2 dst)
829 = pprG g (text "\t#GMUL-xxxcase1" $$
830 hcat [gtab, gpush src2 0,
831 text " ; fmulp %st(0),", greg src1 1])
833 = pprG g (text "\t#GMUL-xxxcase2" $$
834 hcat [gtab, gpush src1 0,
835 text " ; fmulp %st(0),", greg src2 1])
837 = pprG g (hcat [gtab, gpush src1 0,
838 text " ; fmul ", greg src2 1, text ",%st(0)",
842 pprInstr g@(GSUB _ src1 src2 dst)
844 = pprG g (text "\t#GSUB-xxxcase1" $$
845 hcat [gtab, gpush src2 0,
846 text " ; fsubrp %st(0),", greg src1 1])
848 = pprG g (text "\t#GSUB-xxxcase2" $$
849 hcat [gtab, gpush src1 0,
850 text " ; fsubp %st(0),", greg src2 1])
852 = pprG g (hcat [gtab, gpush src1 0,
853 text " ; fsub ", greg src2 1, text ",%st(0)",
857 pprInstr g@(GDIV _ src1 src2 dst)
859 = pprG g (text "\t#GDIV-xxxcase1" $$
860 hcat [gtab, gpush src2 0,
861 text " ; fdivrp %st(0),", greg src1 1])
863 = pprG g (text "\t#GDIV-xxxcase2" $$
864 hcat [gtab, gpush src1 0,
865 text " ; fdivp %st(0),", greg src2 1])
867 = pprG g (hcat [gtab, gpush src1 0,
868 text " ; fdiv ", greg src2 1, text ",%st(0)",
873 = vcat [ ptext (sLit "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
874 ptext (sLit "\tffree %st(4) ;ffree %st(5)")
878 = panic "X86.Ppr.pprInstr: no match"
881 pprTrigOp :: String -> Bool -> CLabel -> CLabel -> Reg -> Reg -> Size -> Doc
882 pprTrigOp op -- fsin, fcos or fptan
883 isTan -- we need a couple of extra steps if we're doing tan
884 l1 l2 -- internal labels for us to use
886 = -- We'll be needing %eax later on
887 hcat [gtab, text "pushl %eax;"] $$
888 -- tan is going to use an extra space on the FP stack
889 (if isTan then hcat [gtab, text "ffree %st(6)"] else empty) $$
890 -- First put the value in %st(0) and try to apply the op to it
891 hcat [gpush src 0, text ("; " ++ op)] $$
892 -- Now look to see if C2 was set (overflow, |value| >= 2^63)
893 hcat [gtab, text "fnstsw %ax"] $$
894 hcat [gtab, text "test $0x400,%eax"] $$
895 -- If we were in bounds then jump to the end
896 hcat [gtab, text "je " <> pprCLabel_asm l1] $$
897 -- Otherwise we need to shrink the value. Start by
898 -- loading pi, doubleing it (by adding it to itself),
899 -- and then swapping pi with the value, so the value we
900 -- want to apply op to is in %st(0) again
901 hcat [gtab, text "ffree %st(7); fldpi"] $$
902 hcat [gtab, text "fadd %st(0),%st"] $$
903 hcat [gtab, text "fxch %st(1)"] $$
904 -- Now we have a loop in which we make the value smaller,
905 -- see if it's small enough, and loop if not
906 (pprCLabel_asm l2 <> char ':') $$
907 hcat [gtab, text "fprem1"] $$
908 -- My Debian libc uses fstsw here for the tan code, but I can't
909 -- see any reason why it should need to be different for tan.
910 hcat [gtab, text "fnstsw %ax"] $$
911 hcat [gtab, text "test $0x400,%eax"] $$
912 hcat [gtab, text "jne " <> pprCLabel_asm l2] $$
913 hcat [gtab, text "fstp %st(1)"] $$
914 hcat [gtab, text op] $$
915 (pprCLabel_asm l1 <> char ':') $$
916 -- Pop the 1.0 tan gave us
917 (if isTan then hcat [gtab, text "fstp %st(0)"] else empty) $$
919 hcat [gtab, text "popl %eax;"] $$
920 -- And finally make the result the right size
921 hcat [gtab, gcoerceto sz, gpop dst 1]
923 --------------------------
925 -- coerce %st(0) to the specified size
926 gcoerceto :: Size -> Doc
927 gcoerceto FF64 = empty
928 gcoerceto FF32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
929 gcoerceto _ = panic "X86.Ppr.gcoerceto: no match"
931 gpush :: Reg -> RegNo -> Doc
933 = hcat [text "fld ", greg reg offset]
935 gpop :: Reg -> RegNo -> Doc
937 = hcat [text "fstp ", greg reg offset]
939 greg :: Reg -> RegNo -> Doc
940 greg reg offset = text "%st(" <> int (gregno reg - firstfake+offset) <> char ')'
951 gregno :: Reg -> RegNo
952 gregno (RegReal (RealRegSingle i)) = i
953 gregno _ = --pprPanic "gregno" (ppr other)
954 999 -- bogus; only needed for debug printing
956 pprG :: Instr -> Doc -> Doc
958 = (char '#' <> pprGInstr fake) $$ actual
961 pprGInstr :: Instr -> Doc
962 pprGInstr (GMOV src dst) = pprSizeRegReg (sLit "gmov") FF64 src dst
963 pprGInstr (GLD sz src dst) = pprSizeAddrReg (sLit "gld") sz src dst
964 pprGInstr (GST sz src dst) = pprSizeRegAddr (sLit "gst") sz src dst
966 pprGInstr (GLDZ dst) = pprSizeReg (sLit "gldz") FF64 dst
967 pprGInstr (GLD1 dst) = pprSizeReg (sLit "gld1") FF64 dst
969 pprGInstr (GFTOI src dst) = pprSizeSizeRegReg (sLit "gftoi") FF32 II32 src dst
970 pprGInstr (GDTOI src dst) = pprSizeSizeRegReg (sLit "gdtoi") FF64 II32 src dst
972 pprGInstr (GITOF src dst) = pprSizeSizeRegReg (sLit "gitof") II32 FF32 src dst
973 pprGInstr (GITOD src dst) = pprSizeSizeRegReg (sLit "gitod") II32 FF64 src dst
974 pprGInstr (GDTOF src dst) = pprSizeSizeRegReg (sLit "gdtof") FF64 FF32 src dst
976 pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 co src dst
977 pprGInstr (GABS sz src dst) = pprSizeRegReg (sLit "gabs") sz src dst
978 pprGInstr (GNEG sz src dst) = pprSizeRegReg (sLit "gneg") sz src dst
979 pprGInstr (GSQRT sz src dst) = pprSizeRegReg (sLit "gsqrt") sz src dst
980 pprGInstr (GSIN sz _ _ src dst) = pprSizeRegReg (sLit "gsin") sz src dst
981 pprGInstr (GCOS sz _ _ src dst) = pprSizeRegReg (sLit "gcos") sz src dst
982 pprGInstr (GTAN sz _ _ src dst) = pprSizeRegReg (sLit "gtan") sz src dst
984 pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg (sLit "gadd") sz src1 src2 dst
985 pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg (sLit "gsub") sz src1 src2 dst
986 pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg (sLit "gmul") sz src1 src2 dst
987 pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg (sLit "gdiv") sz src1 src2 dst
989 pprGInstr _ = panic "X86.Ppr.pprGInstr: no match"
991 pprDollImm :: Imm -> Doc
992 pprDollImm i = ptext (sLit "$") <> pprImm i
995 pprOperand :: Size -> Operand -> Doc
996 pprOperand s (OpReg r) = pprReg s r
997 pprOperand _ (OpImm i) = pprDollImm i
998 pprOperand _ (OpAddr ea) = pprAddr ea
1001 pprMnemonic_ :: LitString -> Doc
1003 char '\t' <> ptext name <> space
1006 pprMnemonic :: LitString -> Size -> Doc
1007 pprMnemonic name size =
1008 char '\t' <> ptext name <> pprSize size <> space
1011 pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc
1012 pprSizeImmOp name size imm op1
1014 pprMnemonic name size,
1022 pprSizeOp :: LitString -> Size -> Operand -> Doc
1023 pprSizeOp name size op1
1025 pprMnemonic name size,
1030 pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1031 pprSizeOpOp name size op1 op2
1033 pprMnemonic name size,
1034 pprOperand size op1,
1040 pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1041 pprOpOp name size op1 op2
1044 pprOperand size op1,
1050 pprSizeReg :: LitString -> Size -> Reg -> Doc
1051 pprSizeReg name size reg1
1053 pprMnemonic name size,
1058 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
1059 pprSizeRegReg name size reg1 reg2
1061 pprMnemonic name size,
1068 pprRegReg :: LitString -> Reg -> Reg -> Doc
1069 pprRegReg name reg1 reg2
1072 pprReg archWordSize reg1,
1074 pprReg archWordSize reg2
1078 pprSizeOpReg :: LitString -> Size -> Operand -> Reg -> Doc
1079 pprSizeOpReg name size op1 reg2
1081 pprMnemonic name size,
1082 pprOperand size op1,
1084 pprReg archWordSize reg2
1087 pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc
1088 pprCondRegReg name size cond reg1 reg2
1099 pprSizeSizeRegReg :: LitString -> Size -> Size -> Reg -> Reg -> Doc
1100 pprSizeSizeRegReg name size1 size2 reg1 reg2
1112 pprSizeSizeOpReg :: LitString -> Size -> Size -> Operand -> Reg -> Doc
1113 pprSizeSizeOpReg name size1 size2 op1 reg2
1115 pprMnemonic name size2,
1116 pprOperand size1 op1,
1121 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1122 pprSizeRegRegReg name size reg1 reg2 reg3
1124 pprMnemonic name size,
1133 pprSizeAddrReg :: LitString -> Size -> AddrMode -> Reg -> Doc
1134 pprSizeAddrReg name size op dst
1136 pprMnemonic name size,
1143 pprSizeRegAddr :: LitString -> Size -> Reg -> AddrMode -> Doc
1144 pprSizeRegAddr name size src op
1146 pprMnemonic name size,
1153 pprShift :: LitString -> Size -> Operand -> Operand -> Doc
1154 pprShift name size src dest
1156 pprMnemonic name size,
1157 pprOperand II8 src, -- src is 8-bit sized
1159 pprOperand size dest
1163 pprSizeOpOpCoerce :: LitString -> Size -> Size -> Operand -> Operand -> Doc
1164 pprSizeOpOpCoerce name size1 size2 op1 op2
1165 = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
1166 pprOperand size1 op1,
1168 pprOperand size2 op2
1172 pprCondInstr :: LitString -> Cond -> Doc -> Doc
1173 pprCondInstr name cond arg
1174 = hcat [ char '\t', ptext name, pprCond cond, space, arg]