compiler/nativeGen/X86/Ppr.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Pretty-printing assembly language
   4 --
   5 -- (c) The University of Glasgow 1993-2005
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module X86.Ppr (
  10         pprNatCmmTop,
  11         pprBasicBlock,
  12         pprSectionHeader,
  13         pprData,
  14         pprInstr,
  15         pprUserReg,
  16         pprSize,
  17         pprImm,
  18         pprDataItem,
  19 )
  20
  21 where
  22
  23 #include "HsVersions.h"
  24 #include "nativeGen/NCG.h"
  25
  26 import X86.Regs
  27 import X86.Instr
  28 import X86.Cond
  29 import Instruction
  30 import Size
  31 import Reg
  32 import PprBase
  33
  34
  35 import BlockId
  36 import Cmm
  37 import CLabel
  38 import Unique           ( pprUnique )
  39 import Pretty
  40 import FastString
  41 import qualified Outputable
  42 import Outputable       (panic, Outputable)
  43
  44 import Data.Word
  45
  46
  47
  48 -- -----------------------------------------------------------------------------
  49 -- Printing this stuff out
  50
  51 pprNatCmmTop :: NatCmmTop Instr -> Doc
  52 pprNatCmmTop (CmmData section dats) =
  53   pprSectionHeader section $$ vcat (map pprData dats)
  54
  55  -- special case for split markers:
  56 pprNatCmmTop (CmmProc [] lbl _ (ListGraph [])) = pprLabel lbl
  57
  58 pprNatCmmTop (CmmProc info lbl _ (ListGraph blocks)) =
  59   pprSectionHeader Text $$
  60   (if null info then -- blocks guaranteed not null, so label needed
  61        pprLabel lbl
  62    else
  63 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
  64             pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
  65                 <> char ':' $$
  66 #endif
  67        vcat (map pprData info) $$
  68        pprLabel (entryLblToInfoLbl lbl)
  69   ) $$
  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).
  80   $$ if not (null info)
  81                     then text "\t.long "
  82                       <+> pprCLabel_asm (entryLblToInfoLbl lbl)
  83                       <+> char '-'
  84                       <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
  85                     else empty
  86 #endif
  87
  88
  89 pprBasicBlock :: NatBasicBlock Instr -> Doc
  90 pprBasicBlock (BasicBlock (BlockId id) instrs) =
  91   pprLabel (mkAsmTempLabel id) $$
  92   vcat (map pprInstr instrs)
  93
  94
  95 pprData :: CmmStatic -> Doc
  96 pprData (CmmAlign bytes)         = pprAlign bytes
  97 pprData (CmmDataLabel lbl)       = pprLabel lbl
  98 pprData (CmmString str)          = pprASCII str
  99 pprData (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes
 100 pprData (CmmStaticLit lit)       = pprDataItem lit
 101
 102 pprGloblDecl :: CLabel -> Doc
 103 pprGloblDecl lbl
 104   | not (externallyVisibleCLabel lbl) = empty
 105   | otherwise = ptext IF_ARCH_sparc((sLit ".global "),
 106                                     (sLit ".globl ")) <>
 107                 pprCLabel_asm lbl
 108
 109 pprTypeAndSizeDecl :: CLabel -> Doc
 110 #if linux_TARGET_OS
 111 pprTypeAndSizeDecl lbl
 112   | not (externallyVisibleCLabel lbl) = empty
 113   | otherwise = ptext (sLit ".type ") <>
 114                 pprCLabel_asm lbl <> ptext (sLit ", @object")
 115 #else
 116 pprTypeAndSizeDecl _
 117   = empty
 118 #endif
 119
 120 pprLabel :: CLabel -> Doc
 121 pprLabel lbl = pprGloblDecl lbl $$ pprTypeAndSizeDecl lbl $$ (pprCLabel_asm lbl <> char ':')
 122
 123
 124 pprASCII :: [Word8] -> Doc
 125 pprASCII str
 126   = vcat (map do1 str) $$ do1 0
 127     where
 128        do1 :: Word8 -> Doc
 129        do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w)
 130
 131 pprAlign :: Int -> Doc
 132
 133
 134 pprAlign bytes
 135         = ptext (sLit ".align ") <> int IF_OS_darwin(pow2, bytes)
 136   where
 137
 138 #if darwin_TARGET_OS
 139         pow2 = log2 bytes
 140
 141         log2 :: Int -> Int  -- cache the common ones
 142         log2 1 = 0
 143         log2 2 = 1
 144         log2 4 = 2
 145         log2 8 = 3
 146         log2 n = 1 + log2 (n `quot` 2)
 147 #endif
 148
 149 -- -----------------------------------------------------------------------------
 150 -- pprInstr: print an 'Instr'
 151
 152 instance Outputable Instr where
 153     ppr  instr  = Outputable.docToSDoc $ pprInstr instr
 154
 155
 156
 157
 158
 159
 160
 161
 162
 163
 164
 165
 166 #if  i386_TARGET_ARCH || x86_64_TARGET_ARCH
 167 pprUserReg :: Reg -> Doc
 168 pprUserReg = pprReg IF_ARCH_i386(II32,) IF_ARCH_x86_64(II64,)
 169
 170 #else
 171 pprUserReg :: Reg -> Doc
 172 pprUserReg = panic "X86.Ppr.pprUserReg: not defined"
 173
 174 #endif
 175
 176 pprReg :: Size -> Reg -> Doc
 177
 178 pprReg s r
 179   = case r of
 180       RealReg i       -> ppr_reg_no s i
 181       VirtualRegI  u  -> text "%vI_" <> asmSDoc (pprUnique u)
 182       VirtualRegHi u  -> text "%vHi_" <> asmSDoc (pprUnique u)
 183       VirtualRegF  u  -> text "%vF_" <> asmSDoc (pprUnique u)
 184       VirtualRegD  u  -> text "%vD_" <> asmSDoc (pprUnique u)
 185   where
 186 #if i386_TARGET_ARCH
 187     ppr_reg_no :: Size -> Int -> Doc
 188     ppr_reg_no II8   = ppr_reg_byte
 189     ppr_reg_no II16  = ppr_reg_word
 190     ppr_reg_no _    = ppr_reg_long
 191
 192     ppr_reg_byte i = ptext
 193       (case i of {
 194          0 -> sLit "%al";     1 -> sLit "%bl";
 195          2 -> sLit "%cl";     3 -> sLit "%dl";
 196         _  -> sLit "very naughty I386 byte register"
 197       })
 198
 199     ppr_reg_word i = ptext
 200       (case i of {
 201          0 -> sLit "%ax";     1 -> sLit "%bx";
 202          2 -> sLit "%cx";     3 -> sLit "%dx";
 203          4 -> sLit "%si";     5 -> sLit "%di";
 204          6 -> sLit "%bp";     7 -> sLit "%sp";
 205         _  -> sLit "very naughty I386 word register"
 206       })
 207
 208     ppr_reg_long i = ptext
 209       (case i of {
 210          0 -> sLit "%eax";    1 -> sLit "%ebx";
 211          2 -> sLit "%ecx";    3 -> sLit "%edx";
 212          4 -> sLit "%esi";    5 -> sLit "%edi";
 213          6 -> sLit "%ebp";    7 -> sLit "%esp";
 214          8 -> sLit "%fake0";  9 -> sLit "%fake1";
 215         10 -> sLit "%fake2"; 11 -> sLit "%fake3";
 216         12 -> sLit "%fake4"; 13 -> sLit "%fake5";
 217         _  -> sLit "very naughty I386 register"
 218       })
 219 #elif x86_64_TARGET_ARCH
 220     ppr_reg_no :: Size -> Int -> Doc
 221     ppr_reg_no II8   = ppr_reg_byte
 222     ppr_reg_no II16  = ppr_reg_word
 223     ppr_reg_no II32  = ppr_reg_long
 224     ppr_reg_no _    = ppr_reg_quad
 225
 226     ppr_reg_byte i = ptext
 227       (case i of {
 228          0 -> sLit "%al";     1 -> sLit "%bl";
 229          2 -> sLit "%cl";     3 -> sLit "%dl";
 230          4 -> sLit "%sil";    5 -> sLit "%dil"; -- new 8-bit regs!
 231          6 -> sLit "%bpl";    7 -> sLit "%spl";
 232          8 -> sLit "%r8b";    9  -> sLit "%r9b";
 233         10 -> sLit "%r10b";   11 -> sLit "%r11b";
 234         12 -> sLit "%r12b";   13 -> sLit "%r13b";
 235         14 -> sLit "%r14b";   15 -> sLit "%r15b";
 236         _  -> sLit "very naughty x86_64 byte register"
 237       })
 238
 239     ppr_reg_word i = ptext
 240       (case i of {
 241          0 -> sLit "%ax";     1 -> sLit "%bx";
 242          2 -> sLit "%cx";     3 -> sLit "%dx";
 243          4 -> sLit "%si";     5 -> sLit "%di";
 244          6 -> sLit "%bp";     7 -> sLit "%sp";
 245          8 -> sLit "%r8w";    9  -> sLit "%r9w";
 246         10 -> sLit "%r10w";   11 -> sLit "%r11w";
 247         12 -> sLit "%r12w";   13 -> sLit "%r13w";
 248         14 -> sLit "%r14w";   15 -> sLit "%r15w";
 249         _  -> sLit "very naughty x86_64 word register"
 250       })
 251
 252     ppr_reg_long i = ptext
 253       (case i of {
 254          0 -> sLit "%eax";    1  -> sLit "%ebx";
 255          2 -> sLit "%ecx";    3  -> sLit "%edx";
 256          4 -> sLit "%esi";    5  -> sLit "%edi";
 257          6 -> sLit "%ebp";    7  -> sLit "%esp";
 258          8 -> sLit "%r8d";    9  -> sLit "%r9d";
 259         10 -> sLit "%r10d";   11 -> sLit "%r11d";
 260         12 -> sLit "%r12d";   13 -> sLit "%r13d";
 261         14 -> sLit "%r14d";   15 -> sLit "%r15d";
 262         _  -> sLit "very naughty x86_64 register"
 263       })
 264
 265     ppr_reg_quad i = ptext
 266       (case i of {
 267          0 -> sLit "%rax";      1 -> sLit "%rbx";
 268          2 -> sLit "%rcx";      3 -> sLit "%rdx";
 269          4 -> sLit "%rsi";      5 -> sLit "%rdi";
 270          6 -> sLit "%rbp";      7 -> sLit "%rsp";
 271          8 -> sLit "%r8";       9 -> sLit "%r9";
 272         10 -> sLit "%r10";    11 -> sLit "%r11";
 273         12 -> sLit "%r12";    13 -> sLit "%r13";
 274         14 -> sLit "%r14";    15 -> sLit "%r15";
 275         16 -> sLit "%xmm0";   17 -> sLit "%xmm1";
 276         18 -> sLit "%xmm2";   19 -> sLit "%xmm3";
 277         20 -> sLit "%xmm4";   21 -> sLit "%xmm5";
 278         22 -> sLit "%xmm6";   23 -> sLit "%xmm7";
 279         24 -> sLit "%xmm8";   25 -> sLit "%xmm9";
 280         26 -> sLit "%xmm10";  27 -> sLit "%xmm11";
 281         28 -> sLit "%xmm12";  29 -> sLit "%xmm13";
 282         30 -> sLit "%xmm14";  31 -> sLit "%xmm15";
 283         _  -> sLit "very naughty x86_64 register"
 284       })
 285 #else
 286      ppr_reg_no _ = panic "X86.Ppr.ppr_reg_no: no match"
 287 #endif
 288
 289
 290 pprSize :: Size -> Doc
 291 pprSize x
 292  = ptext (case x of
 293                 II8   -> sLit "b"
 294                 II16  -> sLit "w"
 295                 II32  -> sLit "l"
 296                 II64  -> sLit "q"
 297 #if i386_TARGET_ARCH
 298                 FF32  -> sLit "s"
 299                 FF64  -> sLit "l"
 300                 FF80  -> sLit "t"
 301 #elif x86_64_TARGET_ARCH
 302                 FF32  -> sLit "ss"      -- "scalar single-precision float" (SSE2)
 303                 FF64  -> sLit "sd"      -- "scalar double-precision float" (SSE2)
 304 #else
 305                 _     -> panic "X86.Ppr.pprSize: no match"
 306 #endif
 307                 )
 308
 309 pprCond :: Cond -> Doc
 310 pprCond c
 311  = ptext (case c of {
 312                 GEU     -> sLit "ae";   LU    -> sLit "b";
 313                 EQQ     -> sLit "e";    GTT   -> sLit "g";
 314                 GE      -> sLit "ge";   GU    -> sLit "a";
 315                 LTT     -> sLit "l";    LE    -> sLit "le";
 316                 LEU     -> sLit "be";   NE    -> sLit "ne";
 317                 NEG     -> sLit "s";    POS   -> sLit "ns";
 318                 CARRY   -> sLit "c";   OFLO  -> sLit "o";
 319                 PARITY  -> sLit "p";   NOTPARITY -> sLit "np";
 320                 ALWAYS  -> sLit "mp"})
 321
 322
 323 pprImm :: Imm -> Doc
 324 pprImm (ImmInt i)     = int i
 325 pprImm (ImmInteger i) = integer i
 326 pprImm (ImmCLbl l)    = pprCLabel_asm l
 327 pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i
 328 pprImm (ImmLit s)     = s
 329
 330 pprImm (ImmFloat _)  = ptext (sLit "naughty float immediate")
 331 pprImm (ImmDouble _) = ptext (sLit "naughty double immediate")
 332
 333 pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
 334 pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
 335                             <> lparen <> pprImm b <> rparen
 336
 337
 338
 339 pprAddr :: AddrMode -> Doc
 340 pprAddr (ImmAddr imm off)
 341   = let pp_imm = pprImm imm
 342     in
 343     if (off == 0) then
 344         pp_imm
 345     else if (off < 0) then
 346         pp_imm <> int off
 347     else
 348         pp_imm <> char '+' <> int off
 349
 350 pprAddr (AddrBaseIndex base index displacement)
 351   = let
 352         pp_disp  = ppr_disp displacement
 353         pp_off p = pp_disp <> char '(' <> p <> char ')'
 354         pp_reg r = pprReg archWordSize r
 355     in
 356     case (base, index) of
 357       (EABaseNone,  EAIndexNone) -> pp_disp
 358       (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b)
 359       (EABaseRip,   EAIndexNone) -> pp_off (ptext (sLit "%rip"))
 360       (EABaseNone,  EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i)
 361       (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r
 362                                        <> comma <> int i)
 363       _                         -> panic "X86.Ppr.pprAddr: no match"
 364
 365   where
 366     ppr_disp (ImmInt 0) = empty
 367     ppr_disp imm        = pprImm imm
 368
 369
 370 pprSectionHeader :: Section -> Doc
 371 #if  i386_TARGET_ARCH
 372
 373 #    if darwin_TARGET_OS
 374 pprSectionHeader seg
 375  = case seg of
 376         Text                    -> ptext (sLit ".text\n\t.align 2")
 377         Data                    -> ptext (sLit ".data\n\t.align 2")
 378         ReadOnlyData            -> ptext (sLit ".const\n.align 2")
 379         RelocatableReadOnlyData -> ptext (sLit ".const_data\n.align 2")
 380         UninitialisedData       -> ptext (sLit ".data\n\t.align 2")
 381         ReadOnlyData16          -> ptext (sLit ".const\n.align 4")
 382         OtherSection _          -> panic "X86.Ppr.pprSectionHeader: unknown section"
 383
 384 #    else
 385 pprSectionHeader seg
 386  = case seg of
 387         Text                    -> ptext (sLit ".text\n\t.align 4,0x90")
 388         Data                    -> ptext (sLit ".data\n\t.align 4")
 389         ReadOnlyData            -> ptext (sLit ".section .rodata\n\t.align 4")
 390         RelocatableReadOnlyData -> ptext (sLit ".section .data\n\t.align 4")
 391         UninitialisedData       -> ptext (sLit ".section .bss\n\t.align 4")
 392         ReadOnlyData16          -> ptext (sLit ".section .rodata\n\t.align 16")
 393         OtherSection _          -> panic "X86.Ppr.pprSectionHeader: unknown section"
 394
 395 #    endif
 396
 397 #elif x86_64_TARGET_ARCH
 398 #    if  darwin_TARGET_OS
 399 pprSectionHeader seg
 400  = case seg of
 401         Text                    -> ptext (sLit ".text\n.align 3")
 402         Data                    -> ptext (sLit ".data\n.align 3")
 403         ReadOnlyData            -> ptext (sLit ".const\n.align 3")
 404         RelocatableReadOnlyData -> ptext (sLit ".const_data\n.align 3")
 405         UninitialisedData       -> ptext (sLit ".data\n\t.align 3")
 406         ReadOnlyData16          -> ptext (sLit ".const\n.align 4")
 407         OtherSection _          -> panic "PprMach.pprSectionHeader: unknown section"
 408
 409 #    else
 410 pprSectionHeader seg
 411  = case seg of
 412         Text                    -> ptext (sLit ".text\n\t.align 8")
 413         Data                    -> ptext (sLit ".data\n\t.align 8")
 414         ReadOnlyData            -> ptext (sLit ".section .rodata\n\t.align 8")
 415         RelocatableReadOnlyData -> ptext (sLit ".section .data\n\t.align 8")
 416         UninitialisedData       -> ptext (sLit ".section .bss\n\t.align 8")
 417         ReadOnlyData16          -> ptext (sLit ".section .rodata.cst16\n\t.align 16")
 418         OtherSection _          -> panic "PprMach.pprSectionHeader: unknown section"
 419
 420 #    endif
 421
 422 #else
 423 pprSectionHeader _              = panic "X86.Ppr.pprSectionHeader: not defined for this architecture"
 424
 425 #endif
 426
 427
 428
 429
 430 pprDataItem :: CmmLit -> Doc
 431 pprDataItem lit
 432   = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit)
 433     where
 434         imm = litToImm lit
 435
 436         -- These seem to be common:
 437         ppr_item II8   _ = [ptext (sLit "\t.byte\t") <> pprImm imm]
 438         ppr_item II32  _ = [ptext (sLit "\t.long\t") <> pprImm imm]
 439
 440         ppr_item FF32  (CmmFloat r _)
 441            = let bs = floatToBytes (fromRational r)
 442              in  map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
 443
 444         ppr_item FF64 (CmmFloat r _)
 445            = let bs = doubleToBytes (fromRational r)
 446              in  map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
 447
 448 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
 449         ppr_item II16  _ = [ptext (sLit "\t.word\t") <> pprImm imm]
 450 #endif
 451 #if i386_TARGET_ARCH && darwin_TARGET_OS
 452         ppr_item II64 (CmmInt x _)  =
 453                 [ptext (sLit "\t.long\t")
 454                     <> int (fromIntegral (fromIntegral x :: Word32)),
 455                  ptext (sLit "\t.long\t")
 456                     <> int (fromIntegral
 457                         (fromIntegral (x `shiftR` 32) :: Word32))]
 458 #endif
 459 #if i386_TARGET_ARCH || (darwin_TARGET_OS && x86_64_TARGET_ARCH)
 460         ppr_item II64  _ = [ptext (sLit "\t.quad\t") <> pprImm imm]
 461 #endif
 462 #if x86_64_TARGET_ARCH && !darwin_TARGET_OS
 463         -- x86_64: binutils can't handle the R_X86_64_PC64 relocation
 464         -- type, which means we can't do pc-relative 64-bit addresses.
 465         -- Fortunately we're assuming the small memory model, in which
 466         -- all such offsets will fit into 32 bits, so we have to stick
 467         -- to 32-bit offset fields and modify the RTS appropriately
 468         --
 469         -- See Note [x86-64-relative] in includes/InfoTables.h
 470         --
 471         ppr_item II64  x
 472            | isRelativeReloc x =
 473                 [ptext (sLit "\t.long\t") <> pprImm imm,
 474                  ptext (sLit "\t.long\t0")]
 475            | otherwise =
 476                 [ptext (sLit "\t.quad\t") <> pprImm imm]
 477            where
 478                 isRelativeReloc (CmmLabelDiffOff _ _ _) = True
 479                 isRelativeReloc _ = False
 480 #endif
 481
 482         ppr_item _ _
 483                 = panic "X86.Ppr.ppr_item: no match"
 484
 485
 486
 487 pprInstr :: Instr -> Doc
 488
 489 pprInstr (COMMENT _) = empty -- nuke 'em
 490 {-
 491 pprInstr (COMMENT s)
 492    =  IF_ARCH_alpha( ((<>) (ptext (sLit "\t# ")) (ftext s))
 493      ,IF_ARCH_sparc( ((<>) (ptext (sLit "# "))   (ftext s))
 494      ,IF_ARCH_i386( ((<>) (ptext (sLit "# "))   (ftext s))
 495      ,IF_ARCH_x86_64( ((<>) (ptext (sLit "# "))   (ftext s))
 496      ,IF_ARCH_powerpc( IF_OS_linux(
 497         ((<>) (ptext (sLit "# ")) (ftext s)),
 498         ((<>) (ptext (sLit "; ")) (ftext s)))
 499      ,)))))
 500 -}
 501 pprInstr (DELTA d)
 502    = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
 503
 504 pprInstr (NEWBLOCK _)
 505    = panic "PprMach.pprInstr: NEWBLOCK"
 506
 507 pprInstr (LDATA _ _)
 508    = panic "PprMach.pprInstr: LDATA"
 509
 510 {-
 511 pprInstr (SPILL reg slot)
 512    = hcat [
 513         ptext (sLit "\tSPILL"),
 514         char ' ',
 515         pprUserReg reg,
 516         comma,
 517         ptext (sLit "SLOT") <> parens (int slot)]
 518
 519 pprInstr (RELOAD slot reg)
 520    = hcat [
 521         ptext (sLit "\tRELOAD"),
 522         char ' ',
 523         ptext (sLit "SLOT") <> parens (int slot),
 524         comma,
 525         pprUserReg reg]
 526 -}
 527
 528 pprInstr (MOV size src dst)
 529   = pprSizeOpOp (sLit "mov") size src dst
 530
 531 pprInstr (MOVZxL II32 src dst) = pprSizeOpOp (sLit "mov") II32 src dst
 532         -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple
 533         -- movl.  But we represent it as a MOVZxL instruction, because
 534         -- the reg alloc would tend to throw away a plain reg-to-reg
 535         -- move, and we still want it to do that.
 536
 537 pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce (sLit "movz") sizes II32 src dst
 538         -- zero-extension only needs to extend to 32 bits: on x86_64,
 539         -- the remaining zero-extension to 64 bits is automatic, and the 32-bit
 540         -- instruction is shorter.
 541
 542 pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce (sLit "movs") sizes archWordSize src dst
 543
 544 -- here we do some patching, since the physical registers are only set late
 545 -- in the code generation.
 546 pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
 547   | reg1 == reg3
 548   = pprSizeOpOp (sLit "add") size (OpReg reg2) dst
 549
 550 pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
 551   | reg2 == reg3
 552   = pprSizeOpOp (sLit "add") size (OpReg reg1) dst
 553
 554 pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))
 555   | reg1 == reg3
 556   = pprInstr (ADD size (OpImm displ) dst)
 557
 558 pprInstr (LEA size src dst) = pprSizeOpOp (sLit "lea") size src dst
 559
 560 pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
 561   = pprSizeOp (sLit "dec") size dst
 562 pprInstr (ADD size (OpImm (ImmInt 1)) dst)
 563   = pprSizeOp (sLit "inc") size dst
 564 pprInstr (ADD size src dst)
 565   = pprSizeOpOp (sLit "add") size src dst
 566 pprInstr (ADC size src dst)
 567   = pprSizeOpOp (sLit "adc") size src dst
 568 pprInstr (SUB size src dst) = pprSizeOpOp (sLit "sub") size src dst
 569 pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2
 570
 571 {- A hack.  The Intel documentation says that "The two and three
 572    operand forms [of IMUL] may also be used with unsigned operands
 573    because the lower half of the product is the same regardless if
 574    (sic) the operands are signed or unsigned.  The CF and OF flags,
 575    however, cannot be used to determine if the upper half of the
 576    result is non-zero."  So there.
 577 -}
 578 pprInstr (AND size src dst) = pprSizeOpOp (sLit "and") size src dst
 579 pprInstr (OR  size src dst) = pprSizeOpOp (sLit "or")  size src dst
 580
 581 pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst
 582 pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst
 583 pprInstr (XOR size src dst) = pprSizeOpOp (sLit "xor")  size src dst
 584
 585 pprInstr (NOT size op) = pprSizeOp (sLit "not") size op
 586 pprInstr (NEGI size op) = pprSizeOp (sLit "neg") size op
 587
 588 pprInstr (SHL size src dst) = pprShift (sLit "shl") size src dst
 589 pprInstr (SAR size src dst) = pprShift (sLit "sar") size src dst
 590 pprInstr (SHR size src dst) = pprShift (sLit "shr") size src dst
 591
 592 pprInstr (BT  size imm src) = pprSizeImmOp (sLit "bt") size imm src
 593
 594 pprInstr (CMP size src dst)
 595   | is_float size =  pprSizeOpOp (sLit "ucomi") size src dst -- SSE2
 596   | otherwise     =  pprSizeOpOp (sLit "cmp")   size src dst
 597   where
 598         -- This predicate is needed here and nowhere else
 599     is_float FF32       = True
 600     is_float FF64       = True
 601     is_float FF80       = True
 602     is_float _          = False
 603
 604 pprInstr (TEST size src dst) = pprSizeOpOp (sLit "test")  size src dst
 605 pprInstr (PUSH size op) = pprSizeOp (sLit "push") size op
 606 pprInstr (POP size op) = pprSizeOp (sLit "pop") size op
 607
 608 -- both unused (SDM):
 609 -- pprInstr PUSHA = ptext (sLit "\tpushal")
 610 -- pprInstr POPA = ptext (sLit "\tpopal")
 611
 612 pprInstr NOP = ptext (sLit "\tnop")
 613 pprInstr (CLTD II32) = ptext (sLit "\tcltd")
 614 pprInstr (CLTD II64) = ptext (sLit "\tcqto")
 615
 616 pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op)
 617
 618 pprInstr (JXX cond (BlockId id))
 619   = pprCondInstr (sLit "j") cond (pprCLabel_asm lab)
 620   where lab = mkAsmTempLabel id
 621
 622 pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm)
 623
 624 pprInstr (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm)
 625 pprInstr (JMP op)          = (<>) (ptext (sLit "\tjmp *")) (pprOperand archWordSize op)
 626 pprInstr (JMP_TBL op _)  = pprInstr (JMP op)
 627 pprInstr (CALL (Left imm) _)    = (<>) (ptext (sLit "\tcall ")) (pprImm imm)
 628 pprInstr (CALL (Right reg) _)   = (<>) (ptext (sLit "\tcall *")) (pprReg archWordSize reg)
 629
 630 pprInstr (IDIV sz op)   = pprSizeOp (sLit "idiv") sz op
 631 pprInstr (DIV sz op)    = pprSizeOp (sLit "div")  sz op
 632 pprInstr (IMUL2 sz op)  = pprSizeOp (sLit "imul") sz op
 633
 634 -- x86_64 only
 635 pprInstr (MUL size op1 op2) = pprSizeOpOp (sLit "mul") size op1 op2
 636
 637 pprInstr (FDIV size op1 op2) = pprSizeOpOp (sLit "div") size op1 op2
 638
 639 pprInstr (CVTSS2SD from to)   = pprRegReg (sLit "cvtss2sd") from to
 640 pprInstr (CVTSD2SS from to)   = pprRegReg (sLit "cvtsd2ss") from to
 641 pprInstr (CVTTSS2SIQ from to) = pprOpReg  (sLit "cvttss2siq") from to
 642 pprInstr (CVTTSD2SIQ from to) = pprOpReg  (sLit "cvttsd2siq") from to
 643 pprInstr (CVTSI2SS from to)   = pprOpReg  (sLit "cvtsi2ssq") from to
 644 pprInstr (CVTSI2SD from to)   = pprOpReg  (sLit "cvtsi2sdq") from to
 645
 646     -- FETCHGOT for PIC on ELF platforms
 647 pprInstr (FETCHGOT reg)
 648    = vcat [ ptext (sLit "\tcall 1f"),
 649             hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ],
 650             hcat [ ptext (sLit "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "),
 651                    pprReg II32 reg ]
 652           ]
 653
 654     -- FETCHPC for PIC on Darwin/x86
 655     -- get the instruction pointer into a register
 656     -- (Terminology note: the IP is called Program Counter on PPC,
 657     --  and it's a good thing to use the same name on both platforms)
 658 pprInstr (FETCHPC reg)
 659    = vcat [ ptext (sLit "\tcall 1f"),
 660             hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ]
 661           ]
 662
 663
 664 -- -----------------------------------------------------------------------------
 665 -- i386 floating-point
 666
 667 -- Simulating a flat register set on the x86 FP stack is tricky.
 668 -- you have to free %st(7) before pushing anything on the FP reg stack
 669 -- so as to preclude the possibility of a FP stack overflow exception.
 670 pprInstr g@(GMOV src dst)
 671    | src == dst
 672    = empty
 673    | otherwise
 674    = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
 675
 676 -- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FSTP (dst+1)
 677 pprInstr g@(GLD sz addr dst)
 678  = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp,
 679                  pprAddr addr, gsemi, gpop dst 1])
 680
 681 -- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
 682 pprInstr g@(GST sz src addr)
 683  = pprG g (hcat [gtab, gpush src 0, gsemi,
 684                  text "fstp", pprSize sz, gsp, pprAddr addr])
 685
 686 pprInstr g@(GLDZ dst)
 687  = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1])
 688 pprInstr g@(GLD1 dst)
 689  = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1])
 690
 691 pprInstr (GFTOI src dst)
 692    = pprInstr (GDTOI src dst)
 693
 694 pprInstr g@(GDTOI src dst)
 695    = pprG g (vcat [
 696          hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"],
 697          hcat [gtab, gpush src 0],
 698          hcat [gtab, text "movzwl 4(%esp), ", reg,
 699                      text " ; orl $0xC00, ", reg],
 700          hcat [gtab, text "movl ", reg, text ", 0(%esp) ; fldcw 0(%esp)"],
 701          hcat [gtab, text "fistpl 0(%esp)"],
 702          hcat [gtab, text "fldcw 4(%esp) ; movl 0(%esp), ", reg],
 703          hcat [gtab, text "addl $8, %esp"]
 704      ])
 705    where
 706      reg = pprReg II32 dst
 707
 708 pprInstr (GITOF src dst)
 709    = pprInstr (GITOD src dst)
 710
 711 pprInstr g@(GITOD src dst)
 712    = pprG g (hcat [gtab, text "pushl ", pprReg II32 src,
 713                    text " ; ffree %st(7); fildl (%esp) ; ",
 714                    gpop dst 1, text " ; addl $4,%esp"])
 715
 716 {- Gruesome swamp follows.  If you're unfortunate enough to have ventured
 717    this far into the jungle AND you give a Rat's Ass (tm) what's going
 718    on, here's the deal.  Generate code to do a floating point comparison
 719    of src1 and src2, of kind cond, and set the Zero flag if true.
 720
 721    The complications are to do with handling NaNs correctly.  We want the
 722    property that if either argument is NaN, then the result of the
 723    comparison is False ... except if we're comparing for inequality,
 724    in which case the answer is True.
 725
 726    Here's how the general (non-inequality) case works.  As an
 727    example, consider generating the an equality test:
 728
 729      pushl %eax         -- we need to mess with this
 730      <get src1 to top of FPU stack>
 731      fcomp <src2 location in FPU stack> and pop pushed src1
 732                 -- Result of comparison is in FPU Status Register bits
 733                 -- C3 C2 and C0
 734      fstsw %ax  -- Move FPU Status Reg to %ax
 735      sahf       -- move C3 C2 C0 from %ax to integer flag reg
 736      -- now the serious magic begins
 737      setpo %ah     -- %ah = if comparable(neither arg was NaN) then 1 else 0
 738      sete  %al     -- %al = if arg1 == arg2 then 1 else 0
 739      andb %ah,%al  -- %al &= %ah
 740                    -- so %al == 1 iff (comparable && same); else it holds 0
 741      decb %al      -- %al == 0, ZeroFlag=1  iff (comparable && same);
 742                       else %al == 0xFF, ZeroFlag=0
 743      -- the zero flag is now set as we desire.
 744      popl %eax
 745
 746    The special case of inequality differs thusly:
 747
 748      setpe %ah     -- %ah = if incomparable(either arg was NaN) then 1 else 0
 749      setne %al     -- %al = if arg1 /= arg2 then 1 else 0
 750      orb %ah,%al   -- %al = if (incomparable || different) then 1 else 0
 751      decb %al      -- if (incomparable || different) then (%al == 0, ZF=1)
 752                                                      else (%al == 0xFF, ZF=0)
 753 -}
 754 pprInstr g@(GCMP cond src1 src2)
 755    | case cond of { NE -> True; _ -> False }
 756    = pprG g (vcat [
 757         hcat [gtab, text "pushl %eax ; ",gpush src1 0],
 758         hcat [gtab, text "fcomp ", greg src2 1,
 759                     text "; fstsw %ax ; sahf ;  setpe %ah"],
 760         hcat [gtab, text "setne %al ;  ",
 761               text "orb %ah,%al ;  decb %al ;  popl %eax"]
 762     ])
 763    | otherwise
 764    = pprG g (vcat [
 765         hcat [gtab, text "pushl %eax ; ",gpush src1 0],
 766         hcat [gtab, text "fcomp ", greg src2 1,
 767                     text "; fstsw %ax ; sahf ;  setpo %ah"],
 768         hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ;  ",
 769               text "andb %ah,%al ;  decb %al ;  popl %eax"]
 770     ])
 771     where
 772         {- On the 486, the flags set by FP compare are the unsigned ones!
 773            (This looks like a HACK to me.  WDP 96/03)
 774         -}
 775         fix_FP_cond :: Cond -> Cond
 776         fix_FP_cond GE   = GEU
 777         fix_FP_cond GTT  = GU
 778         fix_FP_cond LTT  = LU
 779         fix_FP_cond LE   = LEU
 780         fix_FP_cond EQQ  = EQQ
 781         fix_FP_cond NE   = NE
 782         fix_FP_cond _    = panic "X86.Ppr.fix_FP_cond: no match"
 783         -- there should be no others
 784
 785
 786 pprInstr g@(GABS _ src dst)
 787    = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
 788
 789 pprInstr g@(GNEG _ src dst)
 790    = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
 791
 792 pprInstr g@(GSQRT sz src dst)
 793    = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
 794              hcat [gtab, gcoerceto sz, gpop dst 1])
 795
 796 pprInstr g@(GSIN sz l1 l2 src dst)
 797    = pprG g (pprTrigOp "fsin" False l1 l2 src dst sz)
 798
 799 pprInstr g@(GCOS sz l1 l2 src dst)
 800    = pprG g (pprTrigOp "fcos" False l1 l2 src dst sz)
 801
 802 pprInstr g@(GTAN sz l1 l2 src dst)
 803    = pprG g (pprTrigOp "fptan" True l1 l2 src dst sz)
 804
 805 -- In the translations for GADD, GMUL, GSUB and GDIV,
 806 -- the first two cases are mere optimisations.  The otherwise clause
 807 -- generates correct code under all circumstances.
 808
 809 pprInstr g@(GADD _ src1 src2 dst)
 810    | src1 == dst
 811    = pprG g (text "\t#GADD-xxxcase1" $$
 812              hcat [gtab, gpush src2 0,
 813                    text " ; faddp %st(0),", greg src1 1])
 814    | src2 == dst
 815    = pprG g (text "\t#GADD-xxxcase2" $$
 816              hcat [gtab, gpush src1 0,
 817                    text " ; faddp %st(0),", greg src2 1])
 818    | otherwise
 819    = pprG g (hcat [gtab, gpush src1 0,
 820                    text " ; fadd ", greg src2 1, text ",%st(0)",
 821                    gsemi, gpop dst 1])
 822
 823
 824 pprInstr g@(GMUL _ src1 src2 dst)
 825    | src1 == dst
 826    = pprG g (text "\t#GMUL-xxxcase1" $$
 827              hcat [gtab, gpush src2 0,
 828                    text " ; fmulp %st(0),", greg src1 1])
 829    | src2 == dst
 830    = pprG g (text "\t#GMUL-xxxcase2" $$
 831              hcat [gtab, gpush src1 0,
 832                    text " ; fmulp %st(0),", greg src2 1])
 833    | otherwise
 834    = pprG g (hcat [gtab, gpush src1 0,
 835                    text " ; fmul ", greg src2 1, text ",%st(0)",
 836                    gsemi, gpop dst 1])
 837
 838
 839 pprInstr g@(GSUB _ src1 src2 dst)
 840    | src1 == dst
 841    = pprG g (text "\t#GSUB-xxxcase1" $$
 842              hcat [gtab, gpush src2 0,
 843                    text " ; fsubrp %st(0),", greg src1 1])
 844    | src2 == dst
 845    = pprG g (text "\t#GSUB-xxxcase2" $$
 846              hcat [gtab, gpush src1 0,
 847                    text " ; fsubp %st(0),", greg src2 1])
 848    | otherwise
 849    = pprG g (hcat [gtab, gpush src1 0,
 850                    text " ; fsub ", greg src2 1, text ",%st(0)",
 851                    gsemi, gpop dst 1])
 852
 853
 854 pprInstr g@(GDIV _ src1 src2 dst)
 855    | src1 == dst
 856    = pprG g (text "\t#GDIV-xxxcase1" $$
 857              hcat [gtab, gpush src2 0,
 858                    text " ; fdivrp %st(0),", greg src1 1])
 859    | src2 == dst
 860    = pprG g (text "\t#GDIV-xxxcase2" $$
 861              hcat [gtab, gpush src1 0,
 862                    text " ; fdivp %st(0),", greg src2 1])
 863    | otherwise
 864    = pprG g (hcat [gtab, gpush src1 0,
 865                    text " ; fdiv ", greg src2 1, text ",%st(0)",
 866                    gsemi, gpop dst 1])
 867
 868
 869 pprInstr GFREE
 870    = vcat [ ptext (sLit "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
 871             ptext (sLit "\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)")
 872           ]
 873
 874 pprInstr _
 875         = panic "X86.Ppr.pprInstr: no match"
 876
 877
 878 pprTrigOp :: String -> Bool -> CLabel -> CLabel -> Reg -> Reg -> Size -> Doc
 879 pprTrigOp op -- fsin, fcos or fptan
 880           isTan -- we need a couple of extra steps if we're doing tan
 881           l1 l2 -- internal labels for us to use
 882           src dst sz
 883     = -- We'll be needing %eax later on
 884       hcat [gtab, text "pushl %eax;"] $$
 885       -- tan is going to use an extra space on the FP stack
 886       (if isTan then hcat [gtab, text "ffree %st(6)"] else empty) $$
 887       -- First put the value in %st(0) and try to apply the op to it
 888       hcat [gpush src 0, text ("; " ++ op)] $$
 889       -- Now look to see if C2 was set (overflow, |value| >= 2^63)
 890       hcat [gtab, text "fnstsw %ax"] $$
 891       hcat [gtab, text "test   $0x400,%eax"] $$
 892       -- If we were in bounds then jump to the end
 893       hcat [gtab, text "je     " <> pprCLabel_asm l1] $$
 894       -- Otherwise we need to shrink the value. Start by
 895       -- loading pi, doubleing it (by adding it to itself),
 896       -- and then swapping pi with the value, so the value we
 897       -- want to apply op to is in %st(0) again
 898       hcat [gtab, text "ffree %st(7); fldpi"] $$
 899       hcat [gtab, text "fadd   %st(0),%st"] $$
 900       hcat [gtab, text "fxch   %st(1)"] $$
 901       -- Now we have a loop in which we make the value smaller,
 902       -- see if it's small enough, and loop if not
 903       (pprCLabel_asm l2 <> char ':') $$
 904       hcat [gtab, text "fprem1"] $$
 905       -- My Debian libc uses fstsw here for the tan code, but I can't
 906       -- see any reason why it should need to be different for tan.
 907       hcat [gtab, text "fnstsw %ax"] $$
 908       hcat [gtab, text "test   $0x400,%eax"] $$
 909       hcat [gtab, text "jne    " <> pprCLabel_asm l2] $$
 910       hcat [gtab, text "fstp   %st(1)"] $$
 911       hcat [gtab, text op] $$
 912       (pprCLabel_asm l1 <> char ':') $$
 913       -- Pop the 1.0 tan gave us
 914       (if isTan then hcat [gtab, text "fstp %st(0)"] else empty) $$
 915       -- Restore %eax
 916       hcat [gtab, text "popl %eax;"] $$
 917       -- And finally make the result the right size
 918       hcat [gtab, gcoerceto sz, gpop dst 1]
 919
 920 --------------------------
 921
 922 -- coerce %st(0) to the specified size
 923 gcoerceto :: Size -> Doc
 924 gcoerceto FF64 = empty
 925 gcoerceto FF32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
 926 gcoerceto _    = panic "X86.Ppr.gcoerceto: no match"
 927
 928 gpush :: Reg -> RegNo -> Doc
 929 gpush reg offset
 930    = hcat [text "ffree %st(7) ; fld ", greg reg offset]
 931
 932
 933 gpop :: Reg -> RegNo -> Doc
 934 gpop reg offset
 935    = hcat [text "fstp ", greg reg offset]
 936
 937 greg :: Reg -> RegNo -> Doc
 938 greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
 939
 940 gsemi :: Doc
 941 gsemi = text " ; "
 942
 943 gtab :: Doc
 944 gtab  = char '\t'
 945
 946 gsp :: Doc
 947 gsp   = char ' '
 948
 949 gregno :: Reg -> RegNo
 950 gregno (RealReg i) = i
 951 gregno _           = --pprPanic "gregno" (ppr other)
 952                      999   -- bogus; only needed for debug printing
 953
 954 pprG :: Instr -> Doc -> Doc
 955 pprG fake actual
 956    = (char '#' <> pprGInstr fake) $$ actual
 957
 958
 959 pprGInstr :: Instr -> Doc
 960 pprGInstr (GMOV src dst)   = pprSizeRegReg (sLit "gmov") FF64 src dst
 961 pprGInstr (GLD sz src dst) = pprSizeAddrReg (sLit "gld") sz src dst
 962 pprGInstr (GST sz src dst) = pprSizeRegAddr (sLit "gst") sz src dst
 963
 964 pprGInstr (GLDZ dst) = pprSizeReg (sLit "gldz") FF64 dst
 965 pprGInstr (GLD1 dst) = pprSizeReg (sLit "gld1") FF64 dst
 966
 967 pprGInstr (GFTOI src dst) = pprSizeSizeRegReg (sLit "gftoi") FF32 II32  src dst
 968 pprGInstr (GDTOI src dst) = pprSizeSizeRegReg (sLit "gdtoi") FF64 II32 src dst
 969
 970 pprGInstr (GITOF src dst) = pprSizeSizeRegReg (sLit "gitof") II32 FF32  src dst
 971 pprGInstr (GITOD src dst) = pprSizeSizeRegReg (sLit "gitod") II32 FF64 src dst
 972
 973 pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 co src dst
 974 pprGInstr (GABS sz src dst) = pprSizeRegReg (sLit "gabs") sz src dst
 975 pprGInstr (GNEG sz src dst) = pprSizeRegReg (sLit "gneg") sz src dst
 976 pprGInstr (GSQRT sz src dst) = pprSizeRegReg (sLit "gsqrt") sz src dst
 977 pprGInstr (GSIN sz _ _ src dst) = pprSizeRegReg (sLit "gsin") sz src dst
 978 pprGInstr (GCOS sz _ _ src dst) = pprSizeRegReg (sLit "gcos") sz src dst
 979 pprGInstr (GTAN sz _ _ src dst) = pprSizeRegReg (sLit "gtan") sz src dst
 980
 981 pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg (sLit "gadd") sz src1 src2 dst
 982 pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg (sLit "gsub") sz src1 src2 dst
 983 pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg (sLit "gmul") sz src1 src2 dst
 984 pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg (sLit "gdiv") sz src1 src2 dst
 985
 986 pprGInstr _ = panic "X86.Ppr.pprGInstr: no match"
 987
 988 pprDollImm :: Imm -> Doc
 989 pprDollImm i =  ptext (sLit "$") <> pprImm i
 990
 991
 992 pprOperand :: Size -> Operand -> Doc
 993 pprOperand s (OpReg r)   = pprReg s r
 994 pprOperand _ (OpImm i)   = pprDollImm i
 995 pprOperand _ (OpAddr ea) = pprAddr ea
 996
 997
 998 pprMnemonic_  :: LitString -> Doc
 999 pprMnemonic_ name =
1000    char '\t' <> ptext name <> space
1001
1002
1003 pprMnemonic  :: LitString -> Size -> Doc
1004 pprMnemonic name size =
1005    char '\t' <> ptext name <> pprSize size <> space
1006
1007
1008 pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc
1009 pprSizeImmOp name size imm op1
1010   = hcat [
1011         pprMnemonic name size,
1012         char '$',
1013         pprImm imm,
1014         comma,
1015         pprOperand size op1
1016     ]
1017
1018
1019 pprSizeOp :: LitString -> Size -> Operand -> Doc
1020 pprSizeOp name size op1
1021   = hcat [
1022         pprMnemonic name size,
1023         pprOperand size op1
1024     ]
1025
1026
1027 pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1028 pprSizeOpOp name size op1 op2
1029   = hcat [
1030         pprMnemonic name size,
1031         pprOperand size op1,
1032         comma,
1033         pprOperand size op2
1034     ]
1035
1036
1037 pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1038 pprOpOp name size op1 op2
1039   = hcat [
1040         pprMnemonic_ name,
1041         pprOperand size op1,
1042         comma,
1043         pprOperand size op2
1044     ]
1045
1046
1047 pprSizeReg :: LitString -> Size -> Reg -> Doc
1048 pprSizeReg name size reg1
1049   = hcat [
1050         pprMnemonic name size,
1051         pprReg size reg1
1052     ]
1053
1054
1055 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
1056 pprSizeRegReg name size reg1 reg2
1057   = hcat [
1058         pprMnemonic name size,
1059         pprReg size reg1,
1060         comma,
1061         pprReg size reg2
1062     ]
1063
1064
1065 pprRegReg :: LitString -> Reg -> Reg -> Doc
1066 pprRegReg name reg1 reg2
1067   = hcat [
1068         pprMnemonic_ name,
1069         pprReg archWordSize reg1,
1070         comma,
1071         pprReg archWordSize reg2
1072     ]
1073
1074
1075 pprOpReg :: LitString -> Operand -> Reg -> Doc
1076 pprOpReg name op1 reg2
1077   = hcat [
1078         pprMnemonic_ name,
1079         pprOperand archWordSize op1,
1080         comma,
1081         pprReg archWordSize reg2
1082     ]
1083
1084
1085 pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc
1086 pprCondRegReg name size cond reg1 reg2
1087   = hcat [
1088         char '\t',
1089         ptext name,
1090         pprCond cond,
1091         space,
1092         pprReg size reg1,
1093         comma,
1094         pprReg size reg2
1095     ]
1096
1097 pprSizeSizeRegReg :: LitString -> Size -> Size -> Reg -> Reg -> Doc
1098 pprSizeSizeRegReg name size1 size2 reg1 reg2
1099   = hcat [
1100         char '\t',
1101         ptext name,
1102         pprSize size1,
1103         pprSize size2,
1104         space,
1105         pprReg size1 reg1,
1106
1107         comma,
1108         pprReg size2 reg2
1109     ]
1110
1111
1112 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1113 pprSizeRegRegReg name size reg1 reg2 reg3
1114   = hcat [
1115         pprMnemonic name size,
1116         pprReg size reg1,
1117         comma,
1118         pprReg size reg2,
1119         comma,
1120         pprReg size reg3
1121     ]
1122
1123
1124 pprSizeAddrReg :: LitString -> Size -> AddrMode -> Reg -> Doc
1125 pprSizeAddrReg name size op dst
1126   = hcat [
1127         pprMnemonic name size,
1128         pprAddr op,
1129         comma,
1130         pprReg size dst
1131     ]
1132
1133
1134 pprSizeRegAddr :: LitString -> Size -> Reg -> AddrMode -> Doc
1135 pprSizeRegAddr name size src op
1136   = hcat [
1137         pprMnemonic name size,
1138         pprReg size src,
1139         comma,
1140         pprAddr op
1141     ]
1142
1143
1144 pprShift :: LitString -> Size -> Operand -> Operand -> Doc
1145 pprShift name size src dest
1146   = hcat [
1147         pprMnemonic name size,
1148         pprOperand II8 src,  -- src is 8-bit sized
1149         comma,
1150         pprOperand size dest
1151     ]
1152
1153
1154 pprSizeOpOpCoerce :: LitString -> Size -> Size -> Operand -> Operand -> Doc
1155 pprSizeOpOpCoerce name size1 size2 op1 op2
1156   = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
1157         pprOperand size1 op1,
1158         comma,
1159         pprOperand size2 op2
1160     ]
1161
1162
1163 pprCondInstr :: LitString -> Cond -> Doc -> Doc
1164 pprCondInstr name cond arg
1165   = hcat [ char '\t', ptext name, pprCond cond, space, arg]
1166