compiler/nativeGen/PprMach.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Pretty-printing assembly language
   4 --
   5 -- (c) The University of Glasgow 1993-2005
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 -- We start with the @pprXXX@s with some cross-platform commonality
  10 -- (e.g., 'pprReg'); we conclude with the no-commonality monster,
  11 -- 'pprInstr'.
  12
  13 #include "nativeGen/NCG.h"
  14
  15 module PprMach (
  16         pprNatCmmTop, pprBasicBlock,
  17         pprInstr, pprSize, pprUserReg,
  18   ) where
  19
  20
  21 #include "HsVersions.h"
  22
  23 import Cmm
  24 import MachOp           ( MachRep(..), wordRep, isFloatingRep )
  25 import MachRegs         -- may differ per-platform
  26 import MachInstrs
  27
  28 import CLabel           ( CLabel, pprCLabel, externallyVisibleCLabel,
  29                           labelDynamic, mkAsmTempLabel, entryLblToInfoLbl )
  30 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
  31 import CLabel       ( mkDeadStripPreventer )
  32 #endif
  33
  34 import Panic            ( panic )
  35 import Unique           ( pprUnique )
  36 import Pretty
  37 import FastString
  38 import qualified Outputable
  39
  40 import Data.Array.ST
  41 import Data.Word        ( Word8 )
  42 import Control.Monad.ST
  43 import Data.Char        ( chr, ord )
  44 import Data.Maybe       ( isJust )
  45
  46 #if powerpc_TARGET_ARCH || darwin_TARGET_OS
  47 import Data.Word(Word32)
  48 import Data.Bits
  49 #endif
  50
  51 -- -----------------------------------------------------------------------------
  52 -- Printing this stuff out
  53
  54 asmSDoc d = Outputable.withPprStyleDoc (
  55               Outputable.mkCodeStyle Outputable.AsmStyle) d
  56 pprCLabel_asm l = asmSDoc (pprCLabel l)
  57
  58 pprNatCmmTop :: NatCmmTop -> Doc
  59 pprNatCmmTop (CmmData section dats) =
  60   pprSectionHeader section $$ vcat (map pprData dats)
  61
  62  -- special case for split markers:
  63 pprNatCmmTop (CmmProc [] lbl _ []) = pprLabel lbl
  64
  65 pprNatCmmTop (CmmProc info lbl params blocks) =
  66   pprSectionHeader Text $$
  67   (if not (null info)
  68         then
  69 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
  70             pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
  71                 <> char ':' $$
  72 #endif
  73             vcat (map pprData info) $$
  74             pprLabel (entryLblToInfoLbl lbl)
  75         else empty) $$
  76   (case blocks of
  77         [] -> empty
  78         (BasicBlock _ instrs : rest) ->
  79                 (if null info then pprLabel lbl else empty) $$
  80                 -- the first block doesn't get a label:
  81                 vcat (map pprInstr instrs) $$
  82                 vcat (map pprBasicBlock rest)
  83   )
  84 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
  85         -- If we are using the .subsections_via_symbols directive
  86         -- (available on recent versions of Darwin),
  87         -- we have to make sure that there is some kind of reference
  88         -- from the entry code to a label on the _top_ of of the info table,
  89         -- so that the linker will not think it is unreferenced and dead-strip
  90         -- it. That's why the label is called a DeadStripPreventer (_dsp).
  91   $$ if not (null info)
  92                     then text "\t.long "
  93                       <+> pprCLabel_asm (entryLblToInfoLbl lbl)
  94                       <+> char '-'
  95                       <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
  96                     else empty
  97 #endif
  98
  99
 100 pprBasicBlock :: NatBasicBlock -> Doc
 101 pprBasicBlock (BasicBlock (BlockId id) instrs) =
 102   pprLabel (mkAsmTempLabel id) $$
 103   vcat (map pprInstr instrs)
 104
 105 -- -----------------------------------------------------------------------------
 106 -- pprReg: print a 'Reg'
 107
 108 -- For x86, the way we print a register name depends
 109 -- on which bit of it we care about.  Yurgh.
 110
 111 pprUserReg :: Reg -> Doc
 112 pprUserReg = pprReg IF_ARCH_i386(I32,) IF_ARCH_x86_64(I64,)
 113
 114 pprReg :: IF_ARCH_i386(MachRep ->,) IF_ARCH_x86_64(MachRep ->,) Reg -> Doc
 115
 116 pprReg IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) r
 117   = case r of
 118       RealReg i      -> ppr_reg_no IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) i
 119       VirtualRegI  u  -> text "%vI_" <> asmSDoc (pprUnique u)
 120       VirtualRegHi u  -> text "%vHi_" <> asmSDoc (pprUnique u)
 121       VirtualRegF  u  -> text "%vF_" <> asmSDoc (pprUnique u)
 122       VirtualRegD  u  -> text "%vD_" <> asmSDoc (pprUnique u)
 123   where
 124 #if alpha_TARGET_ARCH
 125     ppr_reg_no :: Int -> Doc
 126     ppr_reg_no i = ptext
 127       (case i of {
 128          0 -> SLIT("$0");    1 -> SLIT("$1");
 129          2 -> SLIT("$2");    3 -> SLIT("$3");
 130          4 -> SLIT("$4");    5 -> SLIT("$5");
 131          6 -> SLIT("$6");    7 -> SLIT("$7");
 132          8 -> SLIT("$8");    9 -> SLIT("$9");
 133         10 -> SLIT("$10");  11 -> SLIT("$11");
 134         12 -> SLIT("$12");  13 -> SLIT("$13");
 135         14 -> SLIT("$14");  15 -> SLIT("$15");
 136         16 -> SLIT("$16");  17 -> SLIT("$17");
 137         18 -> SLIT("$18");  19 -> SLIT("$19");
 138         20 -> SLIT("$20");  21 -> SLIT("$21");
 139         22 -> SLIT("$22");  23 -> SLIT("$23");
 140         24 -> SLIT("$24");  25 -> SLIT("$25");
 141         26 -> SLIT("$26");  27 -> SLIT("$27");
 142         28 -> SLIT("$28");  29 -> SLIT("$29");
 143         30 -> SLIT("$30");  31 -> SLIT("$31");
 144         32 -> SLIT("$f0");  33 -> SLIT("$f1");
 145         34 -> SLIT("$f2");  35 -> SLIT("$f3");
 146         36 -> SLIT("$f4");  37 -> SLIT("$f5");
 147         38 -> SLIT("$f6");  39 -> SLIT("$f7");
 148         40 -> SLIT("$f8");  41 -> SLIT("$f9");
 149         42 -> SLIT("$f10"); 43 -> SLIT("$f11");
 150         44 -> SLIT("$f12"); 45 -> SLIT("$f13");
 151         46 -> SLIT("$f14"); 47 -> SLIT("$f15");
 152         48 -> SLIT("$f16"); 49 -> SLIT("$f17");
 153         50 -> SLIT("$f18"); 51 -> SLIT("$f19");
 154         52 -> SLIT("$f20"); 53 -> SLIT("$f21");
 155         54 -> SLIT("$f22"); 55 -> SLIT("$f23");
 156         56 -> SLIT("$f24"); 57 -> SLIT("$f25");
 157         58 -> SLIT("$f26"); 59 -> SLIT("$f27");
 158         60 -> SLIT("$f28"); 61 -> SLIT("$f29");
 159         62 -> SLIT("$f30"); 63 -> SLIT("$f31");
 160         _  -> SLIT("very naughty alpha register")
 161       })
 162 #endif
 163 #if i386_TARGET_ARCH
 164     ppr_reg_no :: MachRep -> Int -> Doc
 165     ppr_reg_no I8   = ppr_reg_byte
 166     ppr_reg_no I16  = ppr_reg_word
 167     ppr_reg_no _    = ppr_reg_long
 168
 169     ppr_reg_byte i = ptext
 170       (case i of {
 171          0 -> SLIT("%al");     1 -> SLIT("%bl");
 172          2 -> SLIT("%cl");     3 -> SLIT("%dl");
 173         _  -> SLIT("very naughty I386 byte register")
 174       })
 175
 176     ppr_reg_word i = ptext
 177       (case i of {
 178          0 -> SLIT("%ax");     1 -> SLIT("%bx");
 179          2 -> SLIT("%cx");     3 -> SLIT("%dx");
 180          4 -> SLIT("%si");     5 -> SLIT("%di");
 181          6 -> SLIT("%bp");     7 -> SLIT("%sp");
 182         _  -> SLIT("very naughty I386 word register")
 183       })
 184
 185     ppr_reg_long i = ptext
 186       (case i of {
 187          0 -> SLIT("%eax");    1 -> SLIT("%ebx");
 188          2 -> SLIT("%ecx");    3 -> SLIT("%edx");
 189          4 -> SLIT("%esi");    5 -> SLIT("%edi");
 190          6 -> SLIT("%ebp");    7 -> SLIT("%esp");
 191          8 -> SLIT("%fake0");  9 -> SLIT("%fake1");
 192         10 -> SLIT("%fake2"); 11 -> SLIT("%fake3");
 193         12 -> SLIT("%fake4"); 13 -> SLIT("%fake5");
 194         _  -> SLIT("very naughty I386 register")
 195       })
 196 #endif
 197
 198 #if x86_64_TARGET_ARCH
 199     ppr_reg_no :: MachRep -> Int -> Doc
 200     ppr_reg_no I8   = ppr_reg_byte
 201     ppr_reg_no I16  = ppr_reg_word
 202     ppr_reg_no I32  = ppr_reg_long
 203     ppr_reg_no _    = ppr_reg_quad
 204
 205     ppr_reg_byte i = ptext
 206       (case i of {
 207          0 -> SLIT("%al");     1 -> SLIT("%bl");
 208          2 -> SLIT("%cl");     3 -> SLIT("%dl");
 209          4 -> SLIT("%sil");    5 -> SLIT("%dil"); -- new 8-bit regs!
 210          6 -> SLIT("%bpl");    7 -> SLIT("%spl");
 211          8 -> SLIT("%r8b");    9  -> SLIT("%r9b");
 212         10 -> SLIT("%r10b");   11 -> SLIT("%r11b");
 213         12 -> SLIT("%r12b");   13 -> SLIT("%r13b");
 214         14 -> SLIT("%r14b");   15 -> SLIT("%r15b");
 215         _  -> SLIT("very naughty x86_64 byte register")
 216       })
 217
 218     ppr_reg_word i = ptext
 219       (case i of {
 220          0 -> SLIT("%ax");     1 -> SLIT("%bx");
 221          2 -> SLIT("%cx");     3 -> SLIT("%dx");
 222          4 -> SLIT("%si");     5 -> SLIT("%di");
 223          6 -> SLIT("%bp");     7 -> SLIT("%sp");
 224          8 -> SLIT("%r8w");    9  -> SLIT("%r9w");
 225         10 -> SLIT("%r10w");   11 -> SLIT("%r11w");
 226         12 -> SLIT("%r12w");   13 -> SLIT("%r13w");
 227         14 -> SLIT("%r14w");   15 -> SLIT("%r15w");
 228         _  -> SLIT("very naughty x86_64 word register")
 229       })
 230
 231     ppr_reg_long i = ptext
 232       (case i of {
 233          0 -> SLIT("%eax");    1  -> SLIT("%ebx");
 234          2 -> SLIT("%ecx");    3  -> SLIT("%edx");
 235          4 -> SLIT("%esi");    5  -> SLIT("%edi");
 236          6 -> SLIT("%ebp");    7  -> SLIT("%esp");
 237          8 -> SLIT("%r8d");    9  -> SLIT("%r9d");
 238         10 -> SLIT("%r10d");   11 -> SLIT("%r11d");
 239         12 -> SLIT("%r12d");   13 -> SLIT("%r13d");
 240         14 -> SLIT("%r14d");   15 -> SLIT("%r15d");
 241         _  -> SLIT("very naughty x86_64 register")
 242       })
 243
 244     ppr_reg_quad i = ptext
 245       (case i of {
 246          0 -> SLIT("%rax");     1 -> SLIT("%rbx");
 247          2 -> SLIT("%rcx");     3 -> SLIT("%rdx");
 248          4 -> SLIT("%rsi");     5 -> SLIT("%rdi");
 249          6 -> SLIT("%rbp");     7 -> SLIT("%rsp");
 250          8 -> SLIT("%r8");      9 -> SLIT("%r9");
 251         10 -> SLIT("%r10");    11 -> SLIT("%r11");
 252         12 -> SLIT("%r12");    13 -> SLIT("%r13");
 253         14 -> SLIT("%r14");    15 -> SLIT("%r15");
 254         16 -> SLIT("%xmm0");   17 -> SLIT("%xmm1");
 255         18 -> SLIT("%xmm2");   19 -> SLIT("%xmm3");
 256         20 -> SLIT("%xmm4");   21 -> SLIT("%xmm5");
 257         22 -> SLIT("%xmm6");   23 -> SLIT("%xmm7");
 258         24 -> SLIT("%xmm8");   25 -> SLIT("%xmm9");
 259         26 -> SLIT("%xmm10");  27 -> SLIT("%xmm11");
 260         28 -> SLIT("%xmm12");  29 -> SLIT("%xmm13");
 261         30 -> SLIT("%xmm14");  31 -> SLIT("%xmm15");
 262         _  -> SLIT("very naughty x86_64 register")
 263       })
 264 #endif
 265
 266 #if sparc_TARGET_ARCH
 267     ppr_reg_no :: Int -> Doc
 268     ppr_reg_no i = ptext
 269       (case i of {
 270          0 -> SLIT("%g0");   1 -> SLIT("%g1");
 271          2 -> SLIT("%g2");   3 -> SLIT("%g3");
 272          4 -> SLIT("%g4");   5 -> SLIT("%g5");
 273          6 -> SLIT("%g6");   7 -> SLIT("%g7");
 274          8 -> SLIT("%o0");   9 -> SLIT("%o1");
 275         10 -> SLIT("%o2");  11 -> SLIT("%o3");
 276         12 -> SLIT("%o4");  13 -> SLIT("%o5");
 277         14 -> SLIT("%o6");  15 -> SLIT("%o7");
 278         16 -> SLIT("%l0");  17 -> SLIT("%l1");
 279         18 -> SLIT("%l2");  19 -> SLIT("%l3");
 280         20 -> SLIT("%l4");  21 -> SLIT("%l5");
 281         22 -> SLIT("%l6");  23 -> SLIT("%l7");
 282         24 -> SLIT("%i0");  25 -> SLIT("%i1");
 283         26 -> SLIT("%i2");  27 -> SLIT("%i3");
 284         28 -> SLIT("%i4");  29 -> SLIT("%i5");
 285         30 -> SLIT("%i6");  31 -> SLIT("%i7");
 286         32 -> SLIT("%f0");  33 -> SLIT("%f1");
 287         34 -> SLIT("%f2");  35 -> SLIT("%f3");
 288         36 -> SLIT("%f4");  37 -> SLIT("%f5");
 289         38 -> SLIT("%f6");  39 -> SLIT("%f7");
 290         40 -> SLIT("%f8");  41 -> SLIT("%f9");
 291         42 -> SLIT("%f10"); 43 -> SLIT("%f11");
 292         44 -> SLIT("%f12"); 45 -> SLIT("%f13");
 293         46 -> SLIT("%f14"); 47 -> SLIT("%f15");
 294         48 -> SLIT("%f16"); 49 -> SLIT("%f17");
 295         50 -> SLIT("%f18"); 51 -> SLIT("%f19");
 296         52 -> SLIT("%f20"); 53 -> SLIT("%f21");
 297         54 -> SLIT("%f22"); 55 -> SLIT("%f23");
 298         56 -> SLIT("%f24"); 57 -> SLIT("%f25");
 299         58 -> SLIT("%f26"); 59 -> SLIT("%f27");
 300         60 -> SLIT("%f28"); 61 -> SLIT("%f29");
 301         62 -> SLIT("%f30"); 63 -> SLIT("%f31");
 302         _  -> SLIT("very naughty sparc register")
 303       })
 304 #endif
 305 #if powerpc_TARGET_ARCH
 306 #if darwin_TARGET_OS
 307     ppr_reg_no :: Int -> Doc
 308     ppr_reg_no i = ptext
 309       (case i of {
 310          0 -> SLIT("r0");   1 -> SLIT("r1");
 311          2 -> SLIT("r2");   3 -> SLIT("r3");
 312          4 -> SLIT("r4");   5 -> SLIT("r5");
 313          6 -> SLIT("r6");   7 -> SLIT("r7");
 314          8 -> SLIT("r8");   9 -> SLIT("r9");
 315         10 -> SLIT("r10");  11 -> SLIT("r11");
 316         12 -> SLIT("r12");  13 -> SLIT("r13");
 317         14 -> SLIT("r14");  15 -> SLIT("r15");
 318         16 -> SLIT("r16");  17 -> SLIT("r17");
 319         18 -> SLIT("r18");  19 -> SLIT("r19");
 320         20 -> SLIT("r20");  21 -> SLIT("r21");
 321         22 -> SLIT("r22");  23 -> SLIT("r23");
 322         24 -> SLIT("r24");  25 -> SLIT("r25");
 323         26 -> SLIT("r26");  27 -> SLIT("r27");
 324         28 -> SLIT("r28");  29 -> SLIT("r29");
 325         30 -> SLIT("r30");  31 -> SLIT("r31");
 326         32 -> SLIT("f0");  33 -> SLIT("f1");
 327         34 -> SLIT("f2");  35 -> SLIT("f3");
 328         36 -> SLIT("f4");  37 -> SLIT("f5");
 329         38 -> SLIT("f6");  39 -> SLIT("f7");
 330         40 -> SLIT("f8");  41 -> SLIT("f9");
 331         42 -> SLIT("f10"); 43 -> SLIT("f11");
 332         44 -> SLIT("f12"); 45 -> SLIT("f13");
 333         46 -> SLIT("f14"); 47 -> SLIT("f15");
 334         48 -> SLIT("f16"); 49 -> SLIT("f17");
 335         50 -> SLIT("f18"); 51 -> SLIT("f19");
 336         52 -> SLIT("f20"); 53 -> SLIT("f21");
 337         54 -> SLIT("f22"); 55 -> SLIT("f23");
 338         56 -> SLIT("f24"); 57 -> SLIT("f25");
 339         58 -> SLIT("f26"); 59 -> SLIT("f27");
 340         60 -> SLIT("f28"); 61 -> SLIT("f29");
 341         62 -> SLIT("f30"); 63 -> SLIT("f31");
 342         _  -> SLIT("very naughty powerpc register")
 343       })
 344 #else
 345     ppr_reg_no :: Int -> Doc
 346     ppr_reg_no i | i <= 31 = int i      -- GPRs
 347                  | i <= 63 = int (i-32) -- FPRs
 348                  | otherwise = ptext SLIT("very naughty powerpc register")
 349 #endif
 350 #endif
 351
 352
 353 -- -----------------------------------------------------------------------------
 354 -- pprSize: print a 'Size'
 355
 356 #if powerpc_TARGET_ARCH || i386_TARGET_ARCH || x86_64_TARGET_ARCH || sparc_TARGET_ARCH
 357 pprSize :: MachRep -> Doc
 358 #else
 359 pprSize :: Size -> Doc
 360 #endif
 361
 362 pprSize x = ptext (case x of
 363 #if alpha_TARGET_ARCH
 364          B  -> SLIT("b")
 365          Bu -> SLIT("bu")
 366 --       W  -> SLIT("w") UNUSED
 367 --       Wu -> SLIT("wu") UNUSED
 368          L  -> SLIT("l")
 369          Q  -> SLIT("q")
 370 --       FF -> SLIT("f") UNUSED
 371 --       DF -> SLIT("d") UNUSED
 372 --       GF -> SLIT("g") UNUSED
 373 --       SF -> SLIT("s") UNUSED
 374          TF -> SLIT("t")
 375 #endif
 376 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
 377         I8   -> SLIT("b")
 378         I16  -> SLIT("w")
 379         I32  -> SLIT("l")
 380         I64  -> SLIT("q")
 381 #endif
 382 #if i386_TARGET_ARCH
 383         F32  -> SLIT("s")
 384         F64  -> SLIT("l")
 385         F80  -> SLIT("t")
 386 #endif
 387 #if x86_64_TARGET_ARCH
 388         F32  -> SLIT("ss")      -- "scalar single-precision float" (SSE2)
 389         F64  -> SLIT("sd")      -- "scalar double-precision float" (SSE2)
 390 #endif
 391 #if sparc_TARGET_ARCH
 392         I8   -> SLIT("sb")
 393         I16   -> SLIT("sh")
 394         I32   -> SLIT("")
 395         F32   -> SLIT("")
 396         F64  -> SLIT("d")
 397     )
 398 pprStSize :: MachRep -> Doc
 399 pprStSize x = ptext (case x of
 400         I8   -> SLIT("b")
 401         I16  -> SLIT("h")
 402         I32  -> SLIT("")
 403         F32  -> SLIT("")
 404         F64  -> SLIT("d")
 405 #endif
 406 #if powerpc_TARGET_ARCH
 407         I8   -> SLIT("b")
 408         I16  -> SLIT("h")
 409         I32  -> SLIT("w")
 410         F32  -> SLIT("fs")
 411         F64  -> SLIT("fd")
 412 #endif
 413     )
 414
 415 -- -----------------------------------------------------------------------------
 416 -- pprCond: print a 'Cond'
 417
 418 pprCond :: Cond -> Doc
 419
 420 pprCond c = ptext (case c of {
 421 #if alpha_TARGET_ARCH
 422         EQQ  -> SLIT("eq");
 423         LTT  -> SLIT("lt");
 424         LE  -> SLIT("le");
 425         ULT -> SLIT("ult");
 426         ULE -> SLIT("ule");
 427         NE  -> SLIT("ne");
 428         GTT  -> SLIT("gt");
 429         GE  -> SLIT("ge")
 430 #endif
 431 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
 432         GEU     -> SLIT("ae");  LU    -> SLIT("b");
 433         EQQ     -> SLIT("e");   GTT   -> SLIT("g");
 434         GE      -> SLIT("ge");  GU    -> SLIT("a");
 435         LTT     -> SLIT("l");   LE    -> SLIT("le");
 436         LEU     -> SLIT("be");  NE    -> SLIT("ne");
 437         NEG     -> SLIT("s");   POS   -> SLIT("ns");
 438         CARRY   -> SLIT("c");   OFLO  -> SLIT("o");
 439         PARITY  -> SLIT("p");   NOTPARITY -> SLIT("np");
 440         ALWAYS  -> SLIT("mp")   -- hack
 441 #endif
 442 #if sparc_TARGET_ARCH
 443         ALWAYS  -> SLIT("");    NEVER -> SLIT("n");
 444         GEU     -> SLIT("geu"); LU    -> SLIT("lu");
 445         EQQ     -> SLIT("e");   GTT   -> SLIT("g");
 446         GE      -> SLIT("ge");  GU    -> SLIT("gu");
 447         LTT     -> SLIT("l");   LE    -> SLIT("le");
 448         LEU     -> SLIT("leu"); NE    -> SLIT("ne");
 449         NEG     -> SLIT("neg"); POS   -> SLIT("pos");
 450         VC      -> SLIT("vc");  VS    -> SLIT("vs")
 451 #endif
 452 #if powerpc_TARGET_ARCH
 453         ALWAYS  -> SLIT("");
 454         EQQ     -> SLIT("eq");  NE    -> SLIT("ne");
 455         LTT     -> SLIT("lt");  GE    -> SLIT("ge");
 456         GTT     -> SLIT("gt");  LE    -> SLIT("le");
 457         LU      -> SLIT("lt");  GEU   -> SLIT("ge");
 458         GU      -> SLIT("gt");  LEU   -> SLIT("le");
 459 #endif
 460     })
 461
 462
 463 -- -----------------------------------------------------------------------------
 464 -- pprImm: print an 'Imm'
 465
 466 pprImm :: Imm -> Doc
 467
 468 pprImm (ImmInt i)     = int i
 469 pprImm (ImmInteger i) = integer i
 470 pprImm (ImmCLbl l)    = pprCLabel_asm l
 471 pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i
 472 pprImm (ImmLit s)     = s
 473
 474 pprImm (ImmFloat _) = ptext SLIT("naughty float immediate")
 475 pprImm (ImmDouble _) = ptext SLIT("naughty double immediate")
 476
 477 pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
 478 #if sparc_TARGET_ARCH
 479 -- ToDo: This should really be fixed in the PIC support, but only
 480 -- print a for now.
 481 pprImm (ImmConstantDiff a b) = pprImm a
 482 #else
 483 pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
 484                             <> lparen <> pprImm b <> rparen
 485 #endif
 486
 487 #if sparc_TARGET_ARCH
 488 pprImm (LO i)
 489   = hcat [ pp_lo, pprImm i, rparen ]
 490   where
 491     pp_lo = text "%lo("
 492
 493 pprImm (HI i)
 494   = hcat [ pp_hi, pprImm i, rparen ]
 495   where
 496     pp_hi = text "%hi("
 497 #endif
 498 #if powerpc_TARGET_ARCH
 499 #if darwin_TARGET_OS
 500 pprImm (LO i)
 501   = hcat [ pp_lo, pprImm i, rparen ]
 502   where
 503     pp_lo = text "lo16("
 504
 505 pprImm (HI i)
 506   = hcat [ pp_hi, pprImm i, rparen ]
 507   where
 508     pp_hi = text "hi16("
 509
 510 pprImm (HA i)
 511   = hcat [ pp_ha, pprImm i, rparen ]
 512   where
 513     pp_ha = text "ha16("
 514
 515 #else
 516 pprImm (LO i)
 517   = pprImm i <> text "@l"
 518
 519 pprImm (HI i)
 520   = pprImm i <> text "@h"
 521
 522 pprImm (HA i)
 523   = pprImm i <> text "@ha"
 524 #endif
 525 #endif
 526
 527
 528 -- -----------------------------------------------------------------------------
 529 -- @pprAddr: print an 'AddrMode'
 530
 531 pprAddr :: AddrMode -> Doc
 532
 533 #if alpha_TARGET_ARCH
 534 pprAddr (AddrReg r) = parens (pprReg r)
 535 pprAddr (AddrImm i) = pprImm i
 536 pprAddr (AddrRegImm r1 i)
 537   = (<>) (pprImm i) (parens (pprReg r1))
 538 #endif
 539
 540 -------------------
 541
 542 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
 543 pprAddr (ImmAddr imm off)
 544   = let pp_imm = pprImm imm
 545     in
 546     if (off == 0) then
 547         pp_imm
 548     else if (off < 0) then
 549         pp_imm <> int off
 550     else
 551         pp_imm <> char '+' <> int off
 552
 553 pprAddr (AddrBaseIndex base index displacement)
 554   = let
 555         pp_disp  = ppr_disp displacement
 556         pp_off p = pp_disp <> char '(' <> p <> char ')'
 557         pp_reg r = pprReg wordRep r
 558     in
 559     case (base,index) of
 560       (EABaseNone,  EAIndexNone) -> pp_disp
 561       (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b)
 562       (EABaseRip,   EAIndexNone) -> pp_off (ptext SLIT("%rip"))
 563       (EABaseNone,  EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i)
 564       (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r
 565                                        <> comma <> int i)
 566   where
 567     ppr_disp (ImmInt 0) = empty
 568     ppr_disp imm        = pprImm imm
 569 #endif
 570
 571 -------------------
 572
 573 #if sparc_TARGET_ARCH
 574 pprAddr (AddrRegReg r1 (RealReg 0)) = pprReg r1
 575
 576 pprAddr (AddrRegReg r1 r2)
 577   = hcat [ pprReg r1, char '+', pprReg r2 ]
 578
 579 pprAddr (AddrRegImm r1 (ImmInt i))
 580   | i == 0 = pprReg r1
 581   | not (fits13Bits i) = largeOffsetError i
 582   | otherwise = hcat [ pprReg r1, pp_sign, int i ]
 583   where
 584     pp_sign = if i > 0 then char '+' else empty
 585
 586 pprAddr (AddrRegImm r1 (ImmInteger i))
 587   | i == 0 = pprReg r1
 588   | not (fits13Bits i) = largeOffsetError i
 589   | otherwise  = hcat [ pprReg r1, pp_sign, integer i ]
 590   where
 591     pp_sign = if i > 0 then char '+' else empty
 592
 593 pprAddr (AddrRegImm r1 imm)
 594   = hcat [ pprReg r1, char '+', pprImm imm ]
 595 #endif
 596
 597 -------------------
 598
 599 #if powerpc_TARGET_ARCH
 600 pprAddr (AddrRegReg r1 r2)
 601   = pprReg r1 <+> ptext SLIT(", ") <+> pprReg r2
 602
 603 pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ]
 604 pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ]
 605 pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]
 606 #endif
 607
 608
 609 -- -----------------------------------------------------------------------------
 610 -- pprData: print a 'CmmStatic'
 611
 612 pprSectionHeader Text
 613     = ptext
 614         IF_ARCH_alpha(SLIT("\t.text\n\t.align 3") {-word boundary-}
 615        ,IF_ARCH_sparc(SLIT(".text\n\t.align 4") {-word boundary-}
 616        ,IF_ARCH_i386(IF_OS_darwin(SLIT(".text\n\t.align 2"),
 617                                   SLIT(".text\n\t.align 4,0x90"))
 618                                   {-needs per-OS variation!-}
 619        ,IF_ARCH_x86_64(IF_OS_darwin(SLIT(".text\n.align 3"),
 620                                     SLIT(".text\n\t.align 8"))
 621        ,IF_ARCH_powerpc(SLIT(".text\n.align 2")
 622        ,)))))
 623 pprSectionHeader Data
 624     = ptext
 625          IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
 626         ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
 627         ,IF_ARCH_i386(IF_OS_darwin(SLIT(".data\n\t.align 2"),
 628                                    SLIT(".data\n\t.align 4"))
 629         ,IF_ARCH_x86_64(IF_OS_darwin(SLIT(".data\n.align 3"),
 630                                      SLIT(".data\n\t.align 8"))
 631         ,IF_ARCH_powerpc(SLIT(".data\n.align 2")
 632         ,)))))
 633 pprSectionHeader ReadOnlyData
 634     = ptext
 635          IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
 636         ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
 637         ,IF_ARCH_i386(IF_OS_darwin(SLIT(".const\n.align 2"),
 638                                    SLIT(".section .rodata\n\t.align 4"))
 639         ,IF_ARCH_x86_64(IF_OS_darwin(SLIT(".const\n.align 3"),
 640                                      SLIT(".section .rodata\n\t.align 8"))
 641         ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const\n.align 2"),
 642                                       SLIT(".section .rodata\n\t.align 2"))
 643         ,)))))
 644 pprSectionHeader RelocatableReadOnlyData
 645     = ptext
 646          IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
 647         ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
 648         ,IF_ARCH_i386(IF_OS_darwin(SLIT(".const_data\n.align 2"),
 649                                    SLIT(".section .rodata\n\t.align 4"))
 650         ,IF_ARCH_x86_64(IF_OS_darwin(SLIT(".const_data\n.align 3"),
 651                                      SLIT(".section .rodata\n\t.align 8"))
 652         ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const_data\n.align 2"),
 653                                       SLIT(".data\n\t.align 2"))
 654         ,)))))
 655 pprSectionHeader UninitialisedData
 656     = ptext
 657          IF_ARCH_alpha(SLIT("\t.bss\n\t.align 3")
 658         ,IF_ARCH_sparc(SLIT(".bss\n\t.align 8") {-<8 will break double constants -}
 659         ,IF_ARCH_i386(IF_OS_darwin(SLIT(".data\n\t.align 2"),
 660                                    SLIT(".section .bss\n\t.align 4"))
 661         ,IF_ARCH_x86_64(IF_OS_darwin(SLIT(".data\n\t.align 3"),
 662                                      SLIT(".section .bss\n\t.align 8"))
 663         ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const_data\n.align 2"),
 664                                       SLIT(".section .bss\n\t.align 2"))
 665         ,)))))
 666 pprSectionHeader ReadOnlyData16
 667     = ptext
 668          IF_ARCH_alpha(SLIT("\t.data\n\t.align 4")
 669         ,IF_ARCH_sparc(SLIT(".data\n\t.align 16")
 670         ,IF_ARCH_i386(IF_OS_darwin(SLIT(".const\n.align 4"),
 671                                    SLIT(".section .rodata\n\t.align 16"))
 672         ,IF_ARCH_x86_64(IF_OS_darwin(SLIT(".const\n.align 4"),
 673                                      SLIT(".section .rodata.cst16\n\t.align 16"))
 674         ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const\n.align 4"),
 675                                       SLIT(".section .rodata\n\t.align 4"))
 676         ,)))))
 677
 678 pprSectionHeader (OtherSection sec)
 679     = panic "PprMach.pprSectionHeader: unknown section"
 680
 681 pprData :: CmmStatic -> Doc
 682 pprData (CmmAlign bytes)         = pprAlign bytes
 683 pprData (CmmDataLabel lbl)       = pprLabel lbl
 684 pprData (CmmString str)          = pprASCII str
 685 pprData (CmmUninitialised bytes) = ptext SLIT(".space ") <> int bytes
 686 pprData (CmmStaticLit lit)       = pprDataItem lit
 687
 688 pprGloblDecl :: CLabel -> Doc
 689 pprGloblDecl lbl
 690   | not (externallyVisibleCLabel lbl) = empty
 691   | otherwise = ptext IF_ARCH_sparc(SLIT(".global "),
 692                                     SLIT(".globl ")) <>
 693                 pprCLabel_asm lbl
 694
 695 pprLabel :: CLabel -> Doc
 696 pprLabel lbl = pprGloblDecl lbl $$ (pprCLabel_asm lbl <> char ':')
 697
 698
 699 pprASCII str
 700   = vcat (map do1 str) $$ do1 0
 701     where
 702        do1 :: Word8 -> Doc
 703        do1 w = ptext SLIT("\t.byte\t") <> int (fromIntegral w)
 704
 705 pprAlign bytes =
 706         IF_ARCH_alpha(ptextSLIT(".align ") <> int pow2,
 707         IF_ARCH_i386(ptext SLIT(".align ") <> int IF_OS_darwin(pow2,bytes),
 708         IF_ARCH_x86_64(ptext SLIT(".align ") <> int IF_OS_darwin(pow2,bytes),
 709         IF_ARCH_sparc(ptext SLIT(".align ") <> int bytes,
 710         IF_ARCH_powerpc(ptext SLIT(".align ") <> int pow2,)))))
 711   where
 712         pow2 = log2 bytes
 713
 714         log2 :: Int -> Int  -- cache the common ones
 715         log2 1 = 0
 716         log2 2 = 1
 717         log2 4 = 2
 718         log2 8 = 3
 719         log2 n = 1 + log2 (n `quot` 2)
 720
 721
 722 pprDataItem :: CmmLit -> Doc
 723 pprDataItem lit
 724   = vcat (ppr_item (cmmLitRep lit) lit)
 725     where
 726         imm = litToImm lit
 727
 728         -- These seem to be common:
 729         ppr_item I8   x = [ptext SLIT("\t.byte\t") <> pprImm imm]
 730         ppr_item I32  x = [ptext SLIT("\t.long\t") <> pprImm imm]
 731         ppr_item F32  (CmmFloat r _)
 732            = let bs = floatToBytes (fromRational r)
 733              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 734         ppr_item F64 (CmmFloat r _)
 735            = let bs = doubleToBytes (fromRational r)
 736              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 737
 738 #if sparc_TARGET_ARCH
 739         -- copy n paste of x86 version
 740         ppr_item I16  x = [ptext SLIT("\t.short\t") <> pprImm imm]
 741         ppr_item I64  x = [ptext SLIT("\t.quad\t") <> pprImm imm]
 742 #endif
 743 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
 744         ppr_item I16  x = [ptext SLIT("\t.word\t") <> pprImm imm]
 745 #endif
 746 #if i386_TARGET_ARCH && darwin_TARGET_OS
 747         ppr_item I64 (CmmInt x _)  =
 748                 [ptext SLIT("\t.long\t")
 749                     <> int (fromIntegral (fromIntegral x :: Word32)),
 750                  ptext SLIT("\t.long\t")
 751                     <> int (fromIntegral
 752                         (fromIntegral (x `shiftR` 32) :: Word32))]
 753 #endif
 754 #if i386_TARGET_ARCH || (darwin_TARGET_OS && x86_64_TARGET_ARCH)
 755         ppr_item I64  x = [ptext SLIT("\t.quad\t") <> pprImm imm]
 756 #endif
 757 #if x86_64_TARGET_ARCH && !darwin_TARGET_OS
 758         -- x86_64: binutils can't handle the R_X86_64_PC64 relocation
 759         -- type, which means we can't do pc-relative 64-bit addresses.
 760         -- Fortunately we're assuming the small memory model, in which
 761         -- all such offsets will fit into 32 bits, so we have to stick
 762         -- to 32-bit offset fields and modify the RTS appropriately
 763         -- (see InfoTables.h).
 764         --
 765         ppr_item I64  x
 766            | isRelativeReloc x =
 767                 [ptext SLIT("\t.long\t") <> pprImm imm,
 768                  ptext SLIT("\t.long\t0")]
 769            | otherwise =
 770                 [ptext SLIT("\t.quad\t") <> pprImm imm]
 771            where
 772                 isRelativeReloc (CmmLabelOff _ _)       = True
 773                 isRelativeReloc (CmmLabelDiffOff _ _ _) = True
 774                 isRelativeReloc _ = False
 775 #endif
 776 #if powerpc_TARGET_ARCH
 777         ppr_item I16 x = [ptext SLIT("\t.short\t") <> pprImm imm]
 778         ppr_item I64 (CmmInt x _)  =
 779                 [ptext SLIT("\t.long\t")
 780                     <> int (fromIntegral
 781                         (fromIntegral (x `shiftR` 32) :: Word32)),
 782                  ptext SLIT("\t.long\t")
 783                     <> int (fromIntegral (fromIntegral x :: Word32))]
 784 #endif
 785
 786 -- fall through to rest of (machine-specific) pprInstr...
 787
 788 -- -----------------------------------------------------------------------------
 789 -- pprInstr: print an 'Instr'
 790
 791 pprInstr :: Instr -> Doc
 792
 793 --pprInstr (COMMENT s) = empty -- nuke 'em
 794 pprInstr (COMMENT s)
 795    =  IF_ARCH_alpha( ((<>) (ptext SLIT("\t# ")) (ftext s))
 796      ,IF_ARCH_sparc( ((<>) (ptext SLIT("! "))   (ftext s))
 797      ,IF_ARCH_i386( ((<>) (ptext SLIT("# "))   (ftext s))
 798      ,IF_ARCH_x86_64( ((<>) (ptext SLIT("# "))   (ftext s))
 799      ,IF_ARCH_powerpc( IF_OS_linux(
 800         ((<>) (ptext SLIT("# ")) (ftext s)),
 801         ((<>) (ptext SLIT("; ")) (ftext s)))
 802      ,)))))
 803
 804 pprInstr (DELTA d)
 805    = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
 806
 807 pprInstr (NEWBLOCK _)
 808    = panic "PprMach.pprInstr: NEWBLOCK"
 809
 810 pprInstr (LDATA _ _)
 811    = panic "PprMach.pprInstr: LDATA"
 812
 813 -- -----------------------------------------------------------------------------
 814 -- pprInstr for an Alpha
 815
 816 #if alpha_TARGET_ARCH
 817
 818 pprInstr (LD size reg addr)
 819   = hcat [
 820         ptext SLIT("\tld"),
 821         pprSize size,
 822         char '\t',
 823         pprReg reg,
 824         comma,
 825         pprAddr addr
 826     ]
 827
 828 pprInstr (LDA reg addr)
 829   = hcat [
 830         ptext SLIT("\tlda\t"),
 831         pprReg reg,
 832         comma,
 833         pprAddr addr
 834     ]
 835
 836 pprInstr (LDAH reg addr)
 837   = hcat [
 838         ptext SLIT("\tldah\t"),
 839         pprReg reg,
 840         comma,
 841         pprAddr addr
 842     ]
 843
 844 pprInstr (LDGP reg addr)
 845   = hcat [
 846         ptext SLIT("\tldgp\t"),
 847         pprReg reg,
 848         comma,
 849         pprAddr addr
 850     ]
 851
 852 pprInstr (LDI size reg imm)
 853   = hcat [
 854         ptext SLIT("\tldi"),
 855         pprSize size,
 856         char '\t',
 857         pprReg reg,
 858         comma,
 859         pprImm imm
 860     ]
 861
 862 pprInstr (ST size reg addr)
 863   = hcat [
 864         ptext SLIT("\tst"),
 865         pprSize size,
 866         char '\t',
 867         pprReg reg,
 868         comma,
 869         pprAddr addr
 870     ]
 871
 872 pprInstr (CLR reg)
 873   = hcat [
 874         ptext SLIT("\tclr\t"),
 875         pprReg reg
 876     ]
 877
 878 pprInstr (ABS size ri reg)
 879   = hcat [
 880         ptext SLIT("\tabs"),
 881         pprSize size,
 882         char '\t',
 883         pprRI ri,
 884         comma,
 885         pprReg reg
 886     ]
 887
 888 pprInstr (NEG size ov ri reg)
 889   = hcat [
 890         ptext SLIT("\tneg"),
 891         pprSize size,
 892         if ov then ptext SLIT("v\t") else char '\t',
 893         pprRI ri,
 894         comma,
 895         pprReg reg
 896     ]
 897
 898 pprInstr (ADD size ov reg1 ri reg2)
 899   = hcat [
 900         ptext SLIT("\tadd"),
 901         pprSize size,
 902         if ov then ptext SLIT("v\t") else char '\t',
 903         pprReg reg1,
 904         comma,
 905         pprRI ri,
 906         comma,
 907         pprReg reg2
 908     ]
 909
 910 pprInstr (SADD size scale reg1 ri reg2)
 911   = hcat [
 912         ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
 913         ptext SLIT("add"),
 914         pprSize size,
 915         char '\t',
 916         pprReg reg1,
 917         comma,
 918         pprRI ri,
 919         comma,
 920         pprReg reg2
 921     ]
 922
 923 pprInstr (SUB size ov reg1 ri reg2)
 924   = hcat [
 925         ptext SLIT("\tsub"),
 926         pprSize size,
 927         if ov then ptext SLIT("v\t") else char '\t',
 928         pprReg reg1,
 929         comma,
 930         pprRI ri,
 931         comma,
 932         pprReg reg2
 933     ]
 934
 935 pprInstr (SSUB size scale reg1 ri reg2)
 936   = hcat [
 937         ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
 938         ptext SLIT("sub"),
 939         pprSize size,
 940         char '\t',
 941         pprReg reg1,
 942         comma,
 943         pprRI ri,
 944         comma,
 945         pprReg reg2
 946     ]
 947
 948 pprInstr (MUL size ov reg1 ri reg2)
 949   = hcat [
 950         ptext SLIT("\tmul"),
 951         pprSize size,
 952         if ov then ptext SLIT("v\t") else char '\t',
 953         pprReg reg1,
 954         comma,
 955         pprRI ri,
 956         comma,
 957         pprReg reg2
 958     ]
 959
 960 pprInstr (DIV size uns reg1 ri reg2)
 961   = hcat [
 962         ptext SLIT("\tdiv"),
 963         pprSize size,
 964         if uns then ptext SLIT("u\t") else char '\t',
 965         pprReg reg1,
 966         comma,
 967         pprRI ri,
 968         comma,
 969         pprReg reg2
 970     ]
 971
 972 pprInstr (REM size uns reg1 ri reg2)
 973   = hcat [
 974         ptext SLIT("\trem"),
 975         pprSize size,
 976         if uns then ptext SLIT("u\t") else char '\t',
 977         pprReg reg1,
 978         comma,
 979         pprRI ri,
 980         comma,
 981         pprReg reg2
 982     ]
 983
 984 pprInstr (NOT ri reg)
 985   = hcat [
 986         ptext SLIT("\tnot"),
 987         char '\t',
 988         pprRI ri,
 989         comma,
 990         pprReg reg
 991     ]
 992
 993 pprInstr (AND reg1 ri reg2) = pprRegRIReg SLIT("and") reg1 ri reg2
 994 pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg SLIT("andnot") reg1 ri reg2
 995 pprInstr (OR reg1 ri reg2) = pprRegRIReg SLIT("or") reg1 ri reg2
 996 pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg SLIT("ornot") reg1 ri reg2
 997 pprInstr (XOR reg1 ri reg2) = pprRegRIReg SLIT("xor") reg1 ri reg2
 998 pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg SLIT("xornot") reg1 ri reg2
 999
1000 pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") reg1 ri reg2
1001 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") reg1 ri reg2
1002 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") reg1 ri reg2
1003
1004 pprInstr (ZAP reg1 ri reg2) = pprRegRIReg SLIT("zap") reg1 ri reg2
1005 pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg SLIT("zapnot") reg1 ri reg2
1006
1007 pprInstr (NOP) = ptext SLIT("\tnop")
1008
1009 pprInstr (CMP cond reg1 ri reg2)
1010   = hcat [
1011         ptext SLIT("\tcmp"),
1012         pprCond cond,
1013         char '\t',
1014         pprReg reg1,
1015         comma,
1016         pprRI ri,
1017         comma,
1018         pprReg reg2
1019     ]
1020
1021 pprInstr (FCLR reg)
1022   = hcat [
1023         ptext SLIT("\tfclr\t"),
1024         pprReg reg
1025     ]
1026
1027 pprInstr (FABS reg1 reg2)
1028   = hcat [
1029         ptext SLIT("\tfabs\t"),
1030         pprReg reg1,
1031         comma,
1032         pprReg reg2
1033     ]
1034
1035 pprInstr (FNEG size reg1 reg2)
1036   = hcat [
1037         ptext SLIT("\tneg"),
1038         pprSize size,
1039         char '\t',
1040         pprReg reg1,
1041         comma,
1042         pprReg reg2
1043     ]
1044
1045 pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("add") size reg1 reg2 reg3
1046 pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("div") size reg1 reg2 reg3
1047 pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("mul") size reg1 reg2 reg3
1048 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("sub") size reg1 reg2 reg3
1049
1050 pprInstr (CVTxy size1 size2 reg1 reg2)
1051   = hcat [
1052         ptext SLIT("\tcvt"),
1053         pprSize size1,
1054         case size2 of {Q -> ptext SLIT("qc"); _ -> pprSize size2},
1055         char '\t',
1056         pprReg reg1,
1057         comma,
1058         pprReg reg2
1059     ]
1060
1061 pprInstr (FCMP size cond reg1 reg2 reg3)
1062   = hcat [
1063         ptext SLIT("\tcmp"),
1064         pprSize size,
1065         pprCond cond,
1066         char '\t',
1067         pprReg reg1,
1068         comma,
1069         pprReg reg2,
1070         comma,
1071         pprReg reg3
1072     ]
1073
1074 pprInstr (FMOV reg1 reg2)
1075   = hcat [
1076         ptext SLIT("\tfmov\t"),
1077         pprReg reg1,
1078         comma,
1079         pprReg reg2
1080     ]
1081
1082 pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
1083
1084 pprInstr (BI NEVER reg lab) = empty
1085
1086 pprInstr (BI cond reg lab)
1087   = hcat [
1088         ptext SLIT("\tb"),
1089         pprCond cond,
1090         char '\t',
1091         pprReg reg,
1092         comma,
1093         pprImm lab
1094     ]
1095
1096 pprInstr (BF cond reg lab)
1097   = hcat [
1098         ptext SLIT("\tfb"),
1099         pprCond cond,
1100         char '\t',
1101         pprReg reg,
1102         comma,
1103         pprImm lab
1104     ]
1105
1106 pprInstr (BR lab)
1107   = (<>) (ptext SLIT("\tbr\t")) (pprImm lab)
1108
1109 pprInstr (JMP reg addr hint)
1110   = hcat [
1111         ptext SLIT("\tjmp\t"),
1112         pprReg reg,
1113         comma,
1114         pprAddr addr,
1115         comma,
1116         int hint
1117     ]
1118
1119 pprInstr (BSR imm n)
1120   = (<>) (ptext SLIT("\tbsr\t")) (pprImm imm)
1121
1122 pprInstr (JSR reg addr n)
1123   = hcat [
1124         ptext SLIT("\tjsr\t"),
1125         pprReg reg,
1126         comma,
1127         pprAddr addr
1128     ]
1129
1130 pprInstr (FUNBEGIN clab)
1131   = hcat [
1132         if (externallyVisibleCLabel clab) then
1133             hcat [ptext SLIT("\t.globl\t"), pp_lab, char '\n']
1134         else
1135             empty,
1136         ptext SLIT("\t.ent "),
1137         pp_lab,
1138         char '\n',
1139         pp_lab,
1140         pp_ldgp,
1141         pp_lab,
1142         pp_frame
1143     ]
1144     where
1145         pp_lab = pprCLabel_asm clab
1146
1147         -- NEVER use commas within those string literals, cpp will ruin your day
1148         pp_ldgp  = hcat [ ptext SLIT(":\n\tldgp $29"), char ',', ptext SLIT("0($27)\n") ]
1149         pp_frame = hcat [ ptext SLIT("..ng:\n\t.frame $30"), char ',',
1150                           ptext SLIT("4240"), char ',',
1151                           ptext SLIT("$26"), char ',',
1152                           ptext SLIT("0\n\t.prologue 1") ]
1153
1154 pprInstr (FUNEND clab)
1155   = (<>) (ptext SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab)
1156 \end{code}
1157
1158 Continue with Alpha-only printing bits and bobs:
1159 \begin{code}
1160 pprRI :: RI -> Doc
1161
1162 pprRI (RIReg r) = pprReg r
1163 pprRI (RIImm r) = pprImm r
1164
1165 pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
1166 pprRegRIReg name reg1 ri reg2
1167   = hcat [
1168         char '\t',
1169         ptext name,
1170         char '\t',
1171         pprReg reg1,
1172         comma,
1173         pprRI ri,
1174         comma,
1175         pprReg reg2
1176     ]
1177
1178 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1179 pprSizeRegRegReg name size reg1 reg2 reg3
1180   = hcat [
1181         char '\t',
1182         ptext name,
1183         pprSize size,
1184         char '\t',
1185         pprReg reg1,
1186         comma,
1187         pprReg reg2,
1188         comma,
1189         pprReg reg3
1190     ]
1191
1192 #endif /* alpha_TARGET_ARCH */
1193
1194
1195 -- -----------------------------------------------------------------------------
1196 -- pprInstr for an x86
1197
1198 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1199
1200 pprInstr v@(MOV size s@(OpReg src) d@(OpReg dst)) -- hack
1201   | src == dst
1202   =
1203 #if 0 /* #ifdef DEBUG */
1204     (<>) (ptext SLIT("# warning: ")) (pprSizeOpOp SLIT("mov") size s d)
1205 #else
1206     empty
1207 #endif
1208
1209 pprInstr (MOV size src dst)
1210   = pprSizeOpOp SLIT("mov") size src dst
1211
1212 pprInstr (MOVZxL I32 src dst) = pprSizeOpOp SLIT("mov") I32 src dst
1213         -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple
1214         -- movl.  But we represent it as a MOVZxL instruction, because
1215         -- the reg alloc would tend to throw away a plain reg-to-reg
1216         -- move, and we still want it to do that.
1217
1218 pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce SLIT("movz") sizes I32 src dst
1219         -- zero-extension only needs to extend to 32 bits: on x86_64,
1220         -- the remaining zero-extension to 64 bits is automatic, and the 32-bit
1221         -- instruction is shorter.
1222
1223 pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce SLIT("movs") sizes wordRep src dst
1224
1225 -- here we do some patching, since the physical registers are only set late
1226 -- in the code generation.
1227 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1228   | reg1 == reg3
1229   = pprSizeOpOp SLIT("add") size (OpReg reg2) dst
1230 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1231   | reg2 == reg3
1232   = pprSizeOpOp SLIT("add") size (OpReg reg1) dst
1233 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))
1234   | reg1 == reg3
1235   = pprInstr (ADD size (OpImm displ) dst)
1236 pprInstr (LEA size src dst) = pprSizeOpOp SLIT("lea") size src dst
1237
1238 pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
1239   = pprSizeOp SLIT("dec") size dst
1240 pprInstr (ADD size (OpImm (ImmInt 1)) dst)
1241   = pprSizeOp SLIT("inc") size dst
1242 pprInstr (ADD size src dst)
1243   = pprSizeOpOp SLIT("add") size src dst
1244 pprInstr (ADC size src dst)
1245   = pprSizeOpOp SLIT("adc") size src dst
1246 pprInstr (SUB size src dst) = pprSizeOpOp SLIT("sub") size src dst
1247 pprInstr (IMUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2
1248
1249 {- A hack.  The Intel documentation says that "The two and three
1250    operand forms [of IMUL] may also be used with unsigned operands
1251    because the lower half of the product is the same regardless if
1252    (sic) the operands are signed or unsigned.  The CF and OF flags,
1253    however, cannot be used to determine if the upper half of the
1254    result is non-zero."  So there.
1255 -}
1256 pprInstr (AND size src dst) = pprSizeOpOp SLIT("and") size src dst
1257 pprInstr (OR  size src dst) = pprSizeOpOp SLIT("or")  size src dst
1258
1259 pprInstr (XOR F32 src dst)  = pprOpOp SLIT("xorps") F32 src dst
1260 pprInstr (XOR F64 src dst)  = pprOpOp SLIT("xorpd") F64 src dst
1261 pprInstr (XOR size src dst) = pprSizeOpOp SLIT("xor")  size src dst
1262
1263 pprInstr (NOT size op) = pprSizeOp SLIT("not") size op
1264 pprInstr (NEGI size op) = pprSizeOp SLIT("neg") size op
1265
1266 pprInstr (SHL size src dst) = pprShift SLIT("shl") size src dst
1267 pprInstr (SAR size src dst) = pprShift SLIT("sar") size src dst
1268 pprInstr (SHR size src dst) = pprShift SLIT("shr") size src dst
1269
1270 pprInstr (BT  size imm src) = pprSizeImmOp SLIT("bt") size imm src
1271
1272 pprInstr (CMP size src dst)
1273   | isFloatingRep size =  pprSizeOpOp SLIT("ucomi")  size src dst -- SSE2
1274   | otherwise          =  pprSizeOpOp SLIT("cmp")  size src dst
1275
1276 pprInstr (TEST size src dst) = pprSizeOpOp SLIT("test")  size src dst
1277 pprInstr (PUSH size op) = pprSizeOp SLIT("push") size op
1278 pprInstr (POP size op) = pprSizeOp SLIT("pop") size op
1279
1280 -- both unused (SDM):
1281 -- pprInstr PUSHA = ptext SLIT("\tpushal")
1282 -- pprInstr POPA = ptext SLIT("\tpopal")
1283
1284 pprInstr NOP = ptext SLIT("\tnop")
1285 pprInstr (CLTD I32) = ptext SLIT("\tcltd")
1286 pprInstr (CLTD I64) = ptext SLIT("\tcqto")
1287
1288 pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand I8 op)
1289
1290 pprInstr (JXX cond (BlockId id))
1291   = pprCondInstr SLIT("j") cond (pprCLabel_asm lab)
1292   where lab = mkAsmTempLabel id
1293
1294 pprInstr (JMP (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
1295 pprInstr (JMP op)          = (<>) (ptext SLIT("\tjmp *")) (pprOperand wordRep op)
1296 pprInstr (JMP_TBL op ids)  = pprInstr (JMP op)
1297 pprInstr (CALL (Left imm) _)    = (<>) (ptext SLIT("\tcall ")) (pprImm imm)
1298 pprInstr (CALL (Right reg) _)   = (<>) (ptext SLIT("\tcall *")) (pprReg wordRep reg)
1299
1300 pprInstr (IDIV sz op)   = pprSizeOp SLIT("idiv") sz op
1301 pprInstr (DIV sz op)    = pprSizeOp SLIT("div")  sz op
1302 pprInstr (IMUL2 sz op)  = pprSizeOp SLIT("imul") sz op
1303
1304 #if x86_64_TARGET_ARCH
1305 pprInstr (MUL size op1 op2) = pprSizeOpOp SLIT("mul") size op1 op2
1306
1307 pprInstr (FDIV size op1 op2) = pprSizeOpOp SLIT("div") size op1 op2
1308
1309 pprInstr (CVTSS2SD from to) = pprRegReg SLIT("cvtss2sd") from to
1310 pprInstr (CVTSD2SS from to) = pprRegReg SLIT("cvtsd2ss") from to
1311 pprInstr (CVTSS2SI from to) = pprOpReg  SLIT("cvtss2siq") from to
1312 pprInstr (CVTSD2SI from to) = pprOpReg  SLIT("cvtsd2siq") from to
1313 pprInstr (CVTSI2SS from to) = pprOpReg  SLIT("cvtsi2ssq") from to
1314 pprInstr (CVTSI2SD from to) = pprOpReg  SLIT("cvtsi2sdq") from to
1315 #endif
1316
1317     -- FETCHGOT for PIC on ELF platforms
1318 pprInstr (FETCHGOT reg)
1319    = vcat [ ptext SLIT("\tcall 1f"),
1320             hcat [ ptext SLIT("1:\tpopl\t"), pprReg I32 reg ],
1321             hcat [ ptext SLIT("\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "),
1322                    pprReg I32 reg ]
1323           ]
1324
1325     -- FETCHPC for PIC on Darwin/x86
1326     -- get the instruction pointer into a register
1327     -- (Terminology note: the IP is called Program Counter on PPC,
1328     --  and it's a good thing to use the same name on both platforms)
1329 pprInstr (FETCHPC reg)
1330    = vcat [ ptext SLIT("\tcall 1f"),
1331             hcat [ ptext SLIT("1:\tpopl\t"), pprReg I32 reg ]
1332           ]
1333
1334
1335
1336 #endif
1337
1338 -- -----------------------------------------------------------------------------
1339 -- i386 floating-point
1340
1341 #if i386_TARGET_ARCH
1342 -- Simulating a flat register set on the x86 FP stack is tricky.
1343 -- you have to free %st(7) before pushing anything on the FP reg stack
1344 -- so as to preclude the possibility of a FP stack overflow exception.
1345 pprInstr g@(GMOV src dst)
1346    | src == dst
1347    = empty
1348    | otherwise
1349    = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
1350
1351 -- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FSTP (dst+1)
1352 pprInstr g@(GLD sz addr dst)
1353  = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp,
1354                  pprAddr addr, gsemi, gpop dst 1])
1355
1356 -- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
1357 pprInstr g@(GST sz src addr)
1358  = pprG g (hcat [gtab, gpush src 0, gsemi,
1359                  text "fstp", pprSize sz, gsp, pprAddr addr])
1360
1361 pprInstr g@(GLDZ dst)
1362  = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1])
1363 pprInstr g@(GLD1 dst)
1364  = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1])
1365
1366 pprInstr g@(GFTOI src dst)
1367    = pprInstr (GDTOI src dst)
1368 pprInstr g@(GDTOI src dst)
1369    = pprG g (hcat [gtab, text "subl $4, %esp ; ",
1370                    gpush src 0, gsemi, text "fistpl 0(%esp) ; popl ",
1371                    pprReg I32 dst])
1372
1373 pprInstr g@(GITOF src dst)
1374    = pprInstr (GITOD src dst)
1375 pprInstr g@(GITOD src dst)
1376    = pprG g (hcat [gtab, text "pushl ", pprReg I32 src,
1377                    text " ; ffree %st(7); fildl (%esp) ; ",
1378                    gpop dst 1, text " ; addl $4,%esp"])
1379
1380 {- Gruesome swamp follows.  If you're unfortunate enough to have ventured
1381    this far into the jungle AND you give a Rat's Ass (tm) what's going
1382    on, here's the deal.  Generate code to do a floating point comparison
1383    of src1 and src2, of kind cond, and set the Zero flag if true.
1384
1385    The complications are to do with handling NaNs correctly.  We want the
1386    property that if either argument is NaN, then the result of the
1387    comparison is False ... except if we're comparing for inequality,
1388    in which case the answer is True.
1389
1390    Here's how the general (non-inequality) case works.  As an
1391    example, consider generating the an equality test:
1392
1393      pushl %eax         -- we need to mess with this
1394      <get src1 to top of FPU stack>
1395      fcomp <src2 location in FPU stack> and pop pushed src1
1396                 -- Result of comparison is in FPU Status Register bits
1397                 -- C3 C2 and C0
1398      fstsw %ax  -- Move FPU Status Reg to %ax
1399      sahf       -- move C3 C2 C0 from %ax to integer flag reg
1400      -- now the serious magic begins
1401      setpo %ah     -- %ah = if comparable(neither arg was NaN) then 1 else 0
1402      sete  %al     -- %al = if arg1 == arg2 then 1 else 0
1403      andb %ah,%al  -- %al &= %ah
1404                    -- so %al == 1 iff (comparable && same); else it holds 0
1405      decb %al      -- %al == 0, ZeroFlag=1  iff (comparable && same);
1406                       else %al == 0xFF, ZeroFlag=0
1407      -- the zero flag is now set as we desire.
1408      popl %eax
1409
1410    The special case of inequality differs thusly:
1411
1412      setpe %ah     -- %ah = if incomparable(either arg was NaN) then 1 else 0
1413      setne %al     -- %al = if arg1 /= arg2 then 1 else 0
1414      orb %ah,%al   -- %al = if (incomparable || different) then 1 else 0
1415      decb %al      -- if (incomparable || different) then (%al == 0, ZF=1)
1416                                                      else (%al == 0xFF, ZF=0)
1417 -}
1418 pprInstr g@(GCMP cond src1 src2)
1419    | case cond of { NE -> True; other -> False }
1420    = pprG g (vcat [
1421         hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1422         hcat [gtab, text "fcomp ", greg src2 1,
1423                     text "; fstsw %ax ; sahf ;  setpe %ah"],
1424         hcat [gtab, text "setne %al ;  ",
1425               text "orb %ah,%al ;  decb %al ;  popl %eax"]
1426     ])
1427    | otherwise
1428    = pprG g (vcat [
1429         hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1430         hcat [gtab, text "fcomp ", greg src2 1,
1431                     text "; fstsw %ax ; sahf ;  setpo %ah"],
1432         hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ;  ",
1433               text "andb %ah,%al ;  decb %al ;  popl %eax"]
1434     ])
1435     where
1436         {- On the 486, the flags set by FP compare are the unsigned ones!
1437            (This looks like a HACK to me.  WDP 96/03)
1438         -}
1439         fix_FP_cond :: Cond -> Cond
1440         fix_FP_cond GE   = GEU
1441         fix_FP_cond GTT  = GU
1442         fix_FP_cond LTT  = LU
1443         fix_FP_cond LE   = LEU
1444         fix_FP_cond EQQ  = EQQ
1445         fix_FP_cond NE   = NE
1446         -- there should be no others
1447
1448
1449 pprInstr g@(GABS sz src dst)
1450    = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
1451 pprInstr g@(GNEG sz src dst)
1452    = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
1453
1454 pprInstr g@(GSQRT sz src dst)
1455    = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
1456              hcat [gtab, gcoerceto sz, gpop dst 1])
1457 pprInstr g@(GSIN sz src dst)
1458    = pprG g (hcat [gtab, gpush src 0, text " ; fsin"] $$
1459              hcat [gtab, gcoerceto sz, gpop dst 1])
1460 pprInstr g@(GCOS sz src dst)
1461    = pprG g (hcat [gtab, gpush src 0, text " ; fcos"] $$
1462              hcat [gtab, gcoerceto sz, gpop dst 1])
1463 pprInstr g@(GTAN sz src dst)
1464    = pprG g (hcat [gtab, text "ffree %st(6) ; ",
1465                    gpush src 0, text " ; fptan ; ",
1466                    text " fstp %st(0)"] $$
1467              hcat [gtab, gcoerceto sz, gpop dst 1])
1468
1469 -- In the translations for GADD, GMUL, GSUB and GDIV,
1470 -- the first two cases are mere optimisations.  The otherwise clause
1471 -- generates correct code under all circumstances.
1472
1473 pprInstr g@(GADD sz src1 src2 dst)
1474    | src1 == dst
1475    = pprG g (text "\t#GADD-xxxcase1" $$
1476              hcat [gtab, gpush src2 0,
1477                    text " ; faddp %st(0),", greg src1 1])
1478    | src2 == dst
1479    = pprG g (text "\t#GADD-xxxcase2" $$
1480              hcat [gtab, gpush src1 0,
1481                    text " ; faddp %st(0),", greg src2 1])
1482    | otherwise
1483    = pprG g (hcat [gtab, gpush src1 0,
1484                    text " ; fadd ", greg src2 1, text ",%st(0)",
1485                    gsemi, gpop dst 1])
1486
1487
1488 pprInstr g@(GMUL sz src1 src2 dst)
1489    | src1 == dst
1490    = pprG g (text "\t#GMUL-xxxcase1" $$
1491              hcat [gtab, gpush src2 0,
1492                    text " ; fmulp %st(0),", greg src1 1])
1493    | src2 == dst
1494    = pprG g (text "\t#GMUL-xxxcase2" $$
1495              hcat [gtab, gpush src1 0,
1496                    text " ; fmulp %st(0),", greg src2 1])
1497    | otherwise
1498    = pprG g (hcat [gtab, gpush src1 0,
1499                    text " ; fmul ", greg src2 1, text ",%st(0)",
1500                    gsemi, gpop dst 1])
1501
1502
1503 pprInstr g@(GSUB sz src1 src2 dst)
1504    | src1 == dst
1505    = pprG g (text "\t#GSUB-xxxcase1" $$
1506              hcat [gtab, gpush src2 0,
1507                    text " ; fsubrp %st(0),", greg src1 1])
1508    | src2 == dst
1509    = pprG g (text "\t#GSUB-xxxcase2" $$
1510              hcat [gtab, gpush src1 0,
1511                    text " ; fsubp %st(0),", greg src2 1])
1512    | otherwise
1513    = pprG g (hcat [gtab, gpush src1 0,
1514                    text " ; fsub ", greg src2 1, text ",%st(0)",
1515                    gsemi, gpop dst 1])
1516
1517
1518 pprInstr g@(GDIV sz src1 src2 dst)
1519    | src1 == dst
1520    = pprG g (text "\t#GDIV-xxxcase1" $$
1521              hcat [gtab, gpush src2 0,
1522                    text " ; fdivrp %st(0),", greg src1 1])
1523    | src2 == dst
1524    = pprG g (text "\t#GDIV-xxxcase2" $$
1525              hcat [gtab, gpush src1 0,
1526                    text " ; fdivp %st(0),", greg src2 1])
1527    | otherwise
1528    = pprG g (hcat [gtab, gpush src1 0,
1529                    text " ; fdiv ", greg src2 1, text ",%st(0)",
1530                    gsemi, gpop dst 1])
1531
1532
1533 pprInstr GFREE
1534    = vcat [ ptext SLIT("\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
1535             ptext SLIT("\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)")
1536           ]
1537
1538 --------------------------
1539
1540 -- coerce %st(0) to the specified size
1541 gcoerceto F64 = empty
1542 gcoerceto F32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
1543
1544 gpush reg offset
1545    = hcat [text "ffree %st(7) ; fld ", greg reg offset]
1546 gpop reg offset
1547    = hcat [text "fstp ", greg reg offset]
1548
1549 greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
1550 gsemi = text " ; "
1551 gtab  = char '\t'
1552 gsp   = char ' '
1553
1554 gregno (RealReg i) = i
1555 gregno other       = --pprPanic "gregno" (ppr other)
1556                      999   -- bogus; only needed for debug printing
1557
1558 pprG :: Instr -> Doc -> Doc
1559 pprG fake actual
1560    = (char '#' <> pprGInstr fake) $$ actual
1561
1562 pprGInstr (GMOV src dst)   = pprSizeRegReg SLIT("gmov") F64 src dst
1563 pprGInstr (GLD sz src dst) = pprSizeAddrReg SLIT("gld") sz src dst
1564 pprGInstr (GST sz src dst) = pprSizeRegAddr SLIT("gst") sz src dst
1565
1566 pprGInstr (GLDZ dst) = pprSizeReg SLIT("gldz") F64 dst
1567 pprGInstr (GLD1 dst) = pprSizeReg SLIT("gld1") F64 dst
1568
1569 pprGInstr (GFTOI src dst) = pprSizeSizeRegReg SLIT("gftoi") F32 I32  src dst
1570 pprGInstr (GDTOI src dst) = pprSizeSizeRegReg SLIT("gdtoi") F64 I32 src dst
1571
1572 pprGInstr (GITOF src dst) = pprSizeSizeRegReg SLIT("gitof") I32 F32  src dst
1573 pprGInstr (GITOD src dst) = pprSizeSizeRegReg SLIT("gitod") I32 F64 src dst
1574
1575 pprGInstr (GCMP co src dst) = pprCondRegReg SLIT("gcmp_") F64 co src dst
1576 pprGInstr (GABS sz src dst) = pprSizeRegReg SLIT("gabs") sz src dst
1577 pprGInstr (GNEG sz src dst) = pprSizeRegReg SLIT("gneg") sz src dst
1578 pprGInstr (GSQRT sz src dst) = pprSizeRegReg SLIT("gsqrt") sz src dst
1579 pprGInstr (GSIN sz src dst) = pprSizeRegReg SLIT("gsin") sz src dst
1580 pprGInstr (GCOS sz src dst) = pprSizeRegReg SLIT("gcos") sz src dst
1581 pprGInstr (GTAN sz src dst) = pprSizeRegReg SLIT("gtan") sz src dst
1582
1583 pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg SLIT("gadd") sz src1 src2 dst
1584 pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg SLIT("gsub") sz src1 src2 dst
1585 pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg SLIT("gmul") sz src1 src2 dst
1586 pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg SLIT("gdiv") sz src1 src2 dst
1587 #endif
1588
1589 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1590
1591 -- Continue with I386-only printing bits and bobs:
1592
1593 pprDollImm :: Imm -> Doc
1594
1595 pprDollImm i =  ptext SLIT("$") <> pprImm i
1596
1597 pprOperand :: MachRep -> Operand -> Doc
1598 pprOperand s (OpReg r)   = pprReg s r
1599 pprOperand s (OpImm i)   = pprDollImm i
1600 pprOperand s (OpAddr ea) = pprAddr ea
1601
1602 pprMnemonic_  :: LitString -> Doc
1603 pprMnemonic_ name =
1604    char '\t' <> ptext name <> space
1605
1606 pprMnemonic  :: LitString -> MachRep -> Doc
1607 pprMnemonic name size =
1608    char '\t' <> ptext name <> pprSize size <> space
1609
1610 pprSizeImmOp :: LitString -> MachRep -> Imm -> Operand -> Doc
1611 pprSizeImmOp name size imm op1
1612   = hcat [
1613         pprMnemonic name size,
1614         char '$',
1615         pprImm imm,
1616         comma,
1617         pprOperand size op1
1618     ]
1619
1620 pprSizeOp :: LitString -> MachRep -> Operand -> Doc
1621 pprSizeOp name size op1
1622   = hcat [
1623         pprMnemonic name size,
1624         pprOperand size op1
1625     ]
1626
1627 pprSizeOpOp :: LitString -> MachRep -> Operand -> Operand -> Doc
1628 pprSizeOpOp name size op1 op2
1629   = hcat [
1630         pprMnemonic name size,
1631         pprOperand size op1,
1632         comma,
1633         pprOperand size op2
1634     ]
1635
1636 pprOpOp :: LitString -> MachRep -> Operand -> Operand -> Doc
1637 pprOpOp name size op1 op2
1638   = hcat [
1639         pprMnemonic_ name,
1640         pprOperand size op1,
1641         comma,
1642         pprOperand size op2
1643     ]
1644
1645 pprSizeReg :: LitString -> MachRep -> Reg -> Doc
1646 pprSizeReg name size reg1
1647   = hcat [
1648         pprMnemonic name size,
1649         pprReg size reg1
1650     ]
1651
1652 pprSizeRegReg :: LitString -> MachRep -> Reg -> Reg -> Doc
1653 pprSizeRegReg name size reg1 reg2
1654   = hcat [
1655         pprMnemonic name size,
1656         pprReg size reg1,
1657         comma,
1658         pprReg size reg2
1659     ]
1660
1661 pprRegReg :: LitString -> Reg -> Reg -> Doc
1662 pprRegReg name reg1 reg2
1663   = hcat [
1664         pprMnemonic_ name,
1665         pprReg wordRep reg1,
1666         comma,
1667         pprReg wordRep reg2
1668     ]
1669
1670 pprOpReg :: LitString -> Operand -> Reg -> Doc
1671 pprOpReg name op1 reg2
1672   = hcat [
1673         pprMnemonic_ name,
1674         pprOperand wordRep op1,
1675         comma,
1676         pprReg wordRep reg2
1677     ]
1678
1679 pprCondRegReg :: LitString -> MachRep -> Cond -> Reg -> Reg -> Doc
1680 pprCondRegReg name size cond reg1 reg2
1681   = hcat [
1682         char '\t',
1683         ptext name,
1684         pprCond cond,
1685         space,
1686         pprReg size reg1,
1687         comma,
1688         pprReg size reg2
1689     ]
1690
1691 pprSizeSizeRegReg :: LitString -> MachRep -> MachRep -> Reg -> Reg -> Doc
1692 pprSizeSizeRegReg name size1 size2 reg1 reg2
1693   = hcat [
1694         char '\t',
1695         ptext name,
1696         pprSize size1,
1697         pprSize size2,
1698         space,
1699         pprReg size1 reg1,
1700
1701         comma,
1702         pprReg size2 reg2
1703     ]
1704
1705 pprSizeRegRegReg :: LitString -> MachRep -> Reg -> Reg -> Reg -> Doc
1706 pprSizeRegRegReg name size reg1 reg2 reg3
1707   = hcat [
1708         pprMnemonic name size,
1709         pprReg size reg1,
1710         comma,
1711         pprReg size reg2,
1712         comma,
1713         pprReg size reg3
1714     ]
1715
1716 pprSizeAddrReg :: LitString -> MachRep -> AddrMode -> Reg -> Doc
1717 pprSizeAddrReg name size op dst
1718   = hcat [
1719         pprMnemonic name size,
1720         pprAddr op,
1721         comma,
1722         pprReg size dst
1723     ]
1724
1725 pprSizeRegAddr :: LitString -> MachRep -> Reg -> AddrMode -> Doc
1726 pprSizeRegAddr name size src op
1727   = hcat [
1728         pprMnemonic name size,
1729         pprReg size src,
1730         comma,
1731         pprAddr op
1732     ]
1733
1734 pprShift :: LitString -> MachRep -> Operand -> Operand -> Doc
1735 pprShift name size src dest
1736   = hcat [
1737         pprMnemonic name size,
1738         pprOperand I8 src,  -- src is 8-bit sized
1739         comma,
1740         pprOperand size dest
1741     ]
1742
1743 pprSizeOpOpCoerce :: LitString -> MachRep -> MachRep -> Operand -> Operand -> Doc
1744 pprSizeOpOpCoerce name size1 size2 op1 op2
1745   = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
1746         pprOperand size1 op1,
1747         comma,
1748         pprOperand size2 op2
1749     ]
1750
1751 pprCondInstr :: LitString -> Cond -> Doc -> Doc
1752 pprCondInstr name cond arg
1753   = hcat [ char '\t', ptext name, pprCond cond, space, arg]
1754
1755 #endif /* i386_TARGET_ARCH */
1756
1757
1758 -- ------------------------------------------------------------------------------- pprInstr for a SPARC
1759
1760 #if sparc_TARGET_ARCH
1761
1762 -- a clumsy hack for now, to handle possible double alignment problems
1763
1764 -- even clumsier, to allow for RegReg regs that show when doing indexed
1765 -- reads (bytearrays).
1766 --
1767
1768 -- Translate to the following:
1769 --    add g1,g2,g1
1770 --    ld  [g1],%fn
1771 --    ld  [g1+4],%f(n+1)
1772 --    sub g1,g2,g1           -- to restore g1
1773
1774 pprInstr (LD F64 (AddrRegReg g1 g2) reg)
1775   = vcat [
1776        hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1777        hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg],
1778        hcat [pp_ld_lbracket, pprReg g1, ptext SLIT("+4]"), comma, pprReg (fPair reg)],
1779        hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1780     ]
1781
1782 -- Translate to
1783 --    ld  [addr],%fn
1784 --    ld  [addr+4],%f(n+1)
1785 pprInstr (LD F64 addr reg) | isJust off_addr
1786   = vcat [
1787        hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
1788        hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg (fPair reg)]
1789     ]
1790   where
1791     off_addr = addrOffset addr 4
1792     addr2 = case off_addr of Just x -> x
1793
1794
1795 pprInstr (LD size addr reg)
1796   = hcat [
1797        ptext SLIT("\tld"),
1798        pprSize size,
1799        char '\t',
1800        lbrack,
1801        pprAddr addr,
1802        pp_rbracket_comma,
1803        pprReg reg
1804     ]
1805
1806 -- The same clumsy hack as above
1807
1808 -- Translate to the following:
1809 --    add g1,g2,g1
1810 --    st  %fn,[g1]
1811 --    st  %f(n+1),[g1+4]
1812 --    sub g1,g2,g1           -- to restore g1
1813 pprInstr (ST F64 reg (AddrRegReg g1 g2))
1814  = vcat [
1815        hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1816        hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1817              pprReg g1, rbrack],
1818        hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1819              pprReg g1, ptext SLIT("+4]")],
1820        hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1821     ]
1822
1823 -- Translate to
1824 --    st  %fn,[addr]
1825 --    st  %f(n+1),[addr+4]
1826 pprInstr (ST F64 reg addr) | isJust off_addr
1827  = vcat [
1828       hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1829             pprAddr addr, rbrack],
1830       hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1831             pprAddr addr2, rbrack]
1832     ]
1833   where
1834     off_addr = addrOffset addr 4
1835     addr2 = case off_addr of Just x -> x
1836
1837 -- no distinction is made between signed and unsigned bytes on stores for the
1838 -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
1839 -- so we call a special-purpose pprSize for ST..
1840
1841 pprInstr (ST size reg addr)
1842   = hcat [
1843        ptext SLIT("\tst"),
1844        pprStSize size,
1845        char '\t',
1846        pprReg reg,
1847        pp_comma_lbracket,
1848        pprAddr addr,
1849        rbrack
1850     ]
1851
1852 pprInstr (ADD x cc reg1 ri reg2)
1853   | not x && not cc && riZero ri
1854   = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1855   | otherwise
1856   = pprRegRIReg (if x then SLIT("addx") else SLIT("add")) cc reg1 ri reg2
1857
1858 pprInstr (SUB x cc reg1 ri reg2)
1859   | not x && cc && reg2 == g0
1860   = hcat [ ptext SLIT("\tcmp\t"), pprReg reg1, comma, pprRI ri ]
1861   | not x && not cc && riZero ri
1862   = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1863   | otherwise
1864   = pprRegRIReg (if x then SLIT("subx") else SLIT("sub")) cc reg1 ri reg2
1865
1866 pprInstr (AND  b reg1 ri reg2) = pprRegRIReg SLIT("and")  b reg1 ri reg2
1867 pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg SLIT("andn") b reg1 ri reg2
1868
1869 pprInstr (OR b reg1 ri reg2)
1870   | not b && reg1 == g0
1871   = let doit = hcat [ ptext SLIT("\tmov\t"), pprRI ri, comma, pprReg reg2 ]
1872     in  case ri of
1873            RIReg rrr | rrr == reg2 -> empty
1874            other                   -> doit
1875   | otherwise
1876   = pprRegRIReg SLIT("or") b reg1 ri reg2
1877
1878 pprInstr (ORN b reg1 ri reg2) = pprRegRIReg SLIT("orn") b reg1 ri reg2
1879
1880 pprInstr (XOR  b reg1 ri reg2) = pprRegRIReg SLIT("xor")  b reg1 ri reg2
1881 pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg SLIT("xnor") b reg1 ri reg2
1882
1883 pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") False reg1 ri reg2
1884 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") False reg1 ri reg2
1885 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") False reg1 ri reg2
1886
1887 pprInstr (RDY rd) = ptext SLIT("\trd\t%y,") <> pprReg rd
1888 pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg SLIT("smul")  b reg1 ri reg2
1889 pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg SLIT("umul")  b reg1 ri reg2
1890
1891 pprInstr (SETHI imm reg)
1892   = hcat [
1893         ptext SLIT("\tsethi\t"),
1894         pprImm imm,
1895         comma,
1896         pprReg reg
1897     ]
1898
1899 pprInstr NOP = ptext SLIT("\tnop")
1900
1901 pprInstr (FABS F32 reg1 reg2) = pprSizeRegReg SLIT("fabs") F32 reg1 reg2
1902 pprInstr (FABS F64 reg1 reg2)
1903   = (<>) (pprSizeRegReg SLIT("fabs") F32 reg1 reg2)
1904     (if (reg1 == reg2) then empty
1905      else (<>) (char '\n')
1906           (pprSizeRegReg SLIT("fmov") F32 (fPair reg1) (fPair reg2)))
1907
1908 pprInstr (FADD size reg1 reg2 reg3)
1909   = pprSizeRegRegReg SLIT("fadd") size reg1 reg2 reg3
1910 pprInstr (FCMP e size reg1 reg2)
1911   = pprSizeRegReg (if e then SLIT("fcmpe") else SLIT("fcmp")) size reg1 reg2
1912 pprInstr (FDIV size reg1 reg2 reg3)
1913   = pprSizeRegRegReg SLIT("fdiv") size reg1 reg2 reg3
1914
1915 pprInstr (FMOV F32 reg1 reg2) = pprSizeRegReg SLIT("fmov") F32 reg1 reg2
1916 pprInstr (FMOV F64 reg1 reg2)
1917   = (<>) (pprSizeRegReg SLIT("fmov") F32 reg1 reg2)
1918     (if (reg1 == reg2) then empty
1919      else (<>) (char '\n')
1920           (pprSizeRegReg SLIT("fmov") F32 (fPair reg1) (fPair reg2)))
1921
1922 pprInstr (FMUL size reg1 reg2 reg3)
1923   = pprSizeRegRegReg SLIT("fmul") size reg1 reg2 reg3
1924
1925 pprInstr (FNEG F32 reg1 reg2) = pprSizeRegReg SLIT("fneg") F32 reg1 reg2
1926 pprInstr (FNEG F64 reg1 reg2)
1927   = (<>) (pprSizeRegReg SLIT("fneg") F32 reg1 reg2)
1928     (if (reg1 == reg2) then empty
1929      else (<>) (char '\n')
1930           (pprSizeRegReg SLIT("fmov") F32 (fPair reg1) (fPair reg2)))
1931
1932 pprInstr (FSQRT size reg1 reg2)     = pprSizeRegReg SLIT("fsqrt") size reg1 reg2
1933 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fsub") size reg1 reg2 reg3
1934 pprInstr (FxTOy size1 size2 reg1 reg2)
1935   = hcat [
1936         ptext SLIT("\tf"),
1937         ptext
1938         (case size1 of
1939             I32  -> SLIT("ito")
1940             F32  -> SLIT("sto")
1941             F64  -> SLIT("dto")),
1942         ptext
1943         (case size2 of
1944             I32  -> SLIT("i\t")
1945             F32  -> SLIT("s\t")
1946             F64  -> SLIT("d\t")),
1947         pprReg reg1, comma, pprReg reg2
1948     ]
1949
1950
1951 pprInstr (BI cond b lab)
1952   = hcat [
1953         ptext SLIT("\tb"), pprCond cond,
1954         if b then pp_comma_a else empty,
1955         char '\t',
1956         pprImm lab
1957     ]
1958
1959 pprInstr (BF cond b lab)
1960   = hcat [
1961         ptext SLIT("\tfb"), pprCond cond,
1962         if b then pp_comma_a else empty,
1963         char '\t',
1964         pprImm lab
1965     ]
1966
1967 pprInstr (JMP addr) = (<>) (ptext SLIT("\tjmp\t")) (pprAddr addr)
1968
1969 pprInstr (CALL (Left imm) n _)
1970   = hcat [ ptext SLIT("\tcall\t"), pprImm imm, comma, int n ]
1971 pprInstr (CALL (Right reg) n _)
1972   = hcat [ ptext SLIT("\tcall\t"), pprReg reg, comma, int n ]
1973
1974 pprRI :: RI -> Doc
1975 pprRI (RIReg r) = pprReg r
1976 pprRI (RIImm r) = pprImm r
1977
1978 pprSizeRegReg :: LitString -> MachRep -> Reg -> Reg -> Doc
1979 pprSizeRegReg name size reg1 reg2
1980   = hcat [
1981         char '\t',
1982         ptext name,
1983         (case size of
1984             F32  -> ptext SLIT("s\t")
1985             F64 -> ptext SLIT("d\t")),
1986         pprReg reg1,
1987         comma,
1988         pprReg reg2
1989     ]
1990
1991 pprSizeRegRegReg :: LitString -> MachRep -> Reg -> Reg -> Reg -> Doc
1992 pprSizeRegRegReg name size reg1 reg2 reg3
1993   = hcat [
1994         char '\t',
1995         ptext name,
1996         (case size of
1997             F32  -> ptext SLIT("s\t")
1998             F64  -> ptext SLIT("d\t")),
1999         pprReg reg1,
2000         comma,
2001         pprReg reg2,
2002         comma,
2003         pprReg reg3
2004     ]
2005
2006 pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
2007 pprRegRIReg name b reg1 ri reg2
2008   = hcat [
2009         char '\t',
2010         ptext name,
2011         if b then ptext SLIT("cc\t") else char '\t',
2012         pprReg reg1,
2013         comma,
2014         pprRI ri,
2015         comma,
2016         pprReg reg2
2017     ]
2018
2019 pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
2020 pprRIReg name b ri reg1
2021   = hcat [
2022         char '\t',
2023         ptext name,
2024         if b then ptext SLIT("cc\t") else char '\t',
2025         pprRI ri,
2026         comma,
2027         pprReg reg1
2028     ]
2029
2030 pp_ld_lbracket    = ptext SLIT("\tld\t[")
2031 pp_rbracket_comma = text "],"
2032 pp_comma_lbracket = text ",["
2033 pp_comma_a        = text ",a"
2034
2035 #endif /* sparc_TARGET_ARCH */
2036
2037
2038 -- -----------------------------------------------------------------------------
2039 -- pprInstr for PowerPC
2040
2041 #if powerpc_TARGET_ARCH
2042 pprInstr (LD sz reg addr) = hcat [
2043         char '\t',
2044         ptext SLIT("l"),
2045         ptext (case sz of
2046             I8  -> SLIT("bz")
2047             I16 -> SLIT("hz")
2048             I32 -> SLIT("wz")
2049             F32 -> SLIT("fs")
2050             F64 -> SLIT("fd")),
2051         case addr of AddrRegImm _ _ -> empty
2052                      AddrRegReg _ _ -> char 'x',
2053         char '\t',
2054         pprReg reg,
2055         ptext SLIT(", "),
2056         pprAddr addr
2057     ]
2058 pprInstr (LA sz reg addr) = hcat [
2059         char '\t',
2060         ptext SLIT("l"),
2061         ptext (case sz of
2062             I8  -> SLIT("ba")
2063             I16 -> SLIT("ha")
2064             I32 -> SLIT("wa")
2065             F32 -> SLIT("fs")
2066             F64 -> SLIT("fd")),
2067         case addr of AddrRegImm _ _ -> empty
2068                      AddrRegReg _ _ -> char 'x',
2069         char '\t',
2070         pprReg reg,
2071         ptext SLIT(", "),
2072         pprAddr addr
2073     ]
2074 pprInstr (ST sz reg addr) = hcat [
2075         char '\t',
2076         ptext SLIT("st"),
2077         pprSize sz,
2078         case addr of AddrRegImm _ _ -> empty
2079                      AddrRegReg _ _ -> char 'x',
2080         char '\t',
2081         pprReg reg,
2082         ptext SLIT(", "),
2083         pprAddr addr
2084     ]
2085 pprInstr (STU sz reg addr) = hcat [
2086         char '\t',
2087         ptext SLIT("st"),
2088         pprSize sz,
2089         ptext SLIT("u\t"),
2090         case addr of AddrRegImm _ _ -> empty
2091                      AddrRegReg _ _ -> char 'x',
2092         pprReg reg,
2093         ptext SLIT(", "),
2094         pprAddr addr
2095     ]
2096 pprInstr (LIS reg imm) = hcat [
2097         char '\t',
2098         ptext SLIT("lis"),
2099         char '\t',
2100         pprReg reg,
2101         ptext SLIT(", "),
2102         pprImm imm
2103     ]
2104 pprInstr (LI reg imm) = hcat [
2105         char '\t',
2106         ptext SLIT("li"),
2107         char '\t',
2108         pprReg reg,
2109         ptext SLIT(", "),
2110         pprImm imm
2111     ]
2112 pprInstr (MR reg1 reg2)
2113     | reg1 == reg2 = empty
2114     | otherwise = hcat [
2115         char '\t',
2116         case regClass reg1 of
2117             RcInteger -> ptext SLIT("mr")
2118             _ -> ptext SLIT("fmr"),
2119         char '\t',
2120         pprReg reg1,
2121         ptext SLIT(", "),
2122         pprReg reg2
2123     ]
2124 pprInstr (CMP sz reg ri) = hcat [
2125         char '\t',
2126         op,
2127         char '\t',
2128         pprReg reg,
2129         ptext SLIT(", "),
2130         pprRI ri
2131     ]
2132     where
2133         op = hcat [
2134                 ptext SLIT("cmp"),
2135                 pprSize sz,
2136                 case ri of
2137                     RIReg _ -> empty
2138                     RIImm _ -> char 'i'
2139             ]
2140 pprInstr (CMPL sz reg ri) = hcat [
2141         char '\t',
2142         op,
2143         char '\t',
2144         pprReg reg,
2145         ptext SLIT(", "),
2146         pprRI ri
2147     ]
2148     where
2149         op = hcat [
2150                 ptext SLIT("cmpl"),
2151                 pprSize sz,
2152                 case ri of
2153                     RIReg _ -> empty
2154                     RIImm _ -> char 'i'
2155             ]
2156 pprInstr (BCC cond (BlockId id)) = hcat [
2157         char '\t',
2158         ptext SLIT("b"),
2159         pprCond cond,
2160         char '\t',
2161         pprCLabel_asm lbl
2162     ]
2163     where lbl = mkAsmTempLabel id
2164
2165 pprInstr (BCCFAR cond (BlockId id)) = vcat [
2166         hcat [
2167             ptext SLIT("\tb"),
2168             pprCond (condNegate cond),
2169             ptext SLIT("\t$+8")
2170         ],
2171         hcat [
2172             ptext SLIT("\tb\t"),
2173             pprCLabel_asm lbl
2174         ]
2175     ]
2176     where lbl = mkAsmTempLabel id
2177
2178 pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
2179         char '\t',
2180         ptext SLIT("b"),
2181         char '\t',
2182         pprCLabel_asm lbl
2183     ]
2184
2185 pprInstr (MTCTR reg) = hcat [
2186         char '\t',
2187         ptext SLIT("mtctr"),
2188         char '\t',
2189         pprReg reg
2190     ]
2191 pprInstr (BCTR _) = hcat [
2192         char '\t',
2193         ptext SLIT("bctr")
2194     ]
2195 pprInstr (BL lbl _) = hcat [
2196         ptext SLIT("\tbl\t"),
2197         pprCLabel_asm lbl
2198     ]
2199 pprInstr (BCTRL _) = hcat [
2200         char '\t',
2201         ptext SLIT("bctrl")
2202     ]
2203 pprInstr (ADD reg1 reg2 ri) = pprLogic SLIT("add") reg1 reg2 ri
2204 pprInstr (ADDIS reg1 reg2 imm) = hcat [
2205         char '\t',
2206         ptext SLIT("addis"),
2207         char '\t',
2208         pprReg reg1,
2209         ptext SLIT(", "),
2210         pprReg reg2,
2211         ptext SLIT(", "),
2212         pprImm imm
2213     ]
2214
2215 pprInstr (ADDC reg1 reg2 reg3) = pprLogic SLIT("addc") reg1 reg2 (RIReg reg3)
2216 pprInstr (ADDE reg1 reg2 reg3) = pprLogic SLIT("adde") reg1 reg2 (RIReg reg3)
2217 pprInstr (SUBF reg1 reg2 reg3) = pprLogic SLIT("subf") reg1 reg2 (RIReg reg3)
2218 pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic SLIT("mullw") reg1 reg2 ri
2219 pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic SLIT("mull") reg1 reg2 ri
2220 pprInstr (DIVW reg1 reg2 reg3) = pprLogic SLIT("divw") reg1 reg2 (RIReg reg3)
2221 pprInstr (DIVWU reg1 reg2 reg3) = pprLogic SLIT("divwu") reg1 reg2 (RIReg reg3)
2222
2223 pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
2224          hcat [ ptext SLIT("\tmullwo\t"), pprReg reg1, ptext SLIT(", "),
2225                                           pprReg reg2, ptext SLIT(", "),
2226                                           pprReg reg3 ],
2227          hcat [ ptext SLIT("\tmfxer\t"),  pprReg reg1 ],
2228          hcat [ ptext SLIT("\trlwinm\t"), pprReg reg1, ptext SLIT(", "),
2229                                           pprReg reg1, ptext SLIT(", "),
2230                                           ptext SLIT("2, 31, 31") ]
2231     ]
2232
2233         -- for some reason, "andi" doesn't exist.
2234         -- we'll use "andi." instead.
2235 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
2236         char '\t',
2237         ptext SLIT("andi."),
2238         char '\t',
2239         pprReg reg1,
2240         ptext SLIT(", "),
2241         pprReg reg2,
2242         ptext SLIT(", "),
2243         pprImm imm
2244     ]
2245 pprInstr (AND reg1 reg2 ri) = pprLogic SLIT("and") reg1 reg2 ri
2246
2247 pprInstr (OR reg1 reg2 ri) = pprLogic SLIT("or") reg1 reg2 ri
2248 pprInstr (XOR reg1 reg2 ri) = pprLogic SLIT("xor") reg1 reg2 ri
2249
2250 pprInstr (XORIS reg1 reg2 imm) = hcat [
2251         char '\t',
2252         ptext SLIT("xoris"),
2253         char '\t',
2254         pprReg reg1,
2255         ptext SLIT(", "),
2256         pprReg reg2,
2257         ptext SLIT(", "),
2258         pprImm imm
2259     ]
2260
2261 pprInstr (EXTS sz reg1 reg2) = hcat [
2262         char '\t',
2263         ptext SLIT("exts"),
2264         pprSize sz,
2265         char '\t',
2266         pprReg reg1,
2267         ptext SLIT(", "),
2268         pprReg reg2
2269     ]
2270
2271 pprInstr (NEG reg1 reg2) = pprUnary SLIT("neg") reg1 reg2
2272 pprInstr (NOT reg1 reg2) = pprUnary SLIT("not") reg1 reg2
2273
2274 pprInstr (SLW reg1 reg2 ri) = pprLogic SLIT("slw") reg1 reg2 (limitShiftRI ri)
2275 pprInstr (SRW reg1 reg2 ri) = pprLogic SLIT("srw") reg1 reg2 (limitShiftRI ri)
2276 pprInstr (SRAW reg1 reg2 ri) = pprLogic SLIT("sraw") reg1 reg2 (limitShiftRI ri)
2277 pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
2278         ptext SLIT("\trlwinm\t"),
2279         pprReg reg1,
2280         ptext SLIT(", "),
2281         pprReg reg2,
2282         ptext SLIT(", "),
2283         int sh,
2284         ptext SLIT(", "),
2285         int mb,
2286         ptext SLIT(", "),
2287         int me
2288     ]
2289
2290 pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF SLIT("fadd") sz reg1 reg2 reg3
2291 pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF SLIT("fsub") sz reg1 reg2 reg3
2292 pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF SLIT("fmul") sz reg1 reg2 reg3
2293 pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF SLIT("fdiv") sz reg1 reg2 reg3
2294 pprInstr (FNEG reg1 reg2) = pprUnary SLIT("fneg") reg1 reg2
2295
2296 pprInstr (FCMP reg1 reg2) = hcat [
2297         char '\t',
2298         ptext SLIT("fcmpu\tcr0, "),
2299             -- Note: we're using fcmpu, not fcmpo
2300             -- The difference is with fcmpo, compare with NaN is an invalid operation.
2301             -- We don't handle invalid fp ops, so we don't care
2302         pprReg reg1,
2303         ptext SLIT(", "),
2304         pprReg reg2
2305     ]
2306
2307 pprInstr (FCTIWZ reg1 reg2) = pprUnary SLIT("fctiwz") reg1 reg2
2308 pprInstr (FRSP reg1 reg2) = pprUnary SLIT("frsp") reg1 reg2
2309
2310 pprInstr (CRNOR dst src1 src2) = hcat [
2311         ptext SLIT("\tcrnor\t"),
2312         int dst,
2313         ptext SLIT(", "),
2314         int src1,
2315         ptext SLIT(", "),
2316         int src2
2317     ]
2318
2319 pprInstr (MFCR reg) = hcat [
2320         char '\t',
2321         ptext SLIT("mfcr"),
2322         char '\t',
2323         pprReg reg
2324     ]
2325
2326 pprInstr (MFLR reg) = hcat [
2327         char '\t',
2328         ptext SLIT("mflr"),
2329         char '\t',
2330         pprReg reg
2331     ]
2332
2333 pprInstr (FETCHPC reg) = vcat [
2334         ptext SLIT("\tbcl\t20,31,1f"),
2335         hcat [ ptext SLIT("1:\tmflr\t"), pprReg reg ]
2336     ]
2337
2338 pprInstr LWSYNC = ptext SLIT("\tlwsync")
2339
2340 pprInstr _ = panic "pprInstr (ppc)"
2341
2342 pprLogic op reg1 reg2 ri = hcat [
2343         char '\t',
2344         ptext op,
2345         case ri of
2346             RIReg _ -> empty
2347             RIImm _ -> char 'i',
2348         char '\t',
2349         pprReg reg1,
2350         ptext SLIT(", "),
2351         pprReg reg2,
2352         ptext SLIT(", "),
2353         pprRI ri
2354     ]
2355
2356 pprUnary op reg1 reg2 = hcat [
2357         char '\t',
2358         ptext op,
2359         char '\t',
2360         pprReg reg1,
2361         ptext SLIT(", "),
2362         pprReg reg2
2363     ]
2364
2365 pprBinaryF op sz reg1 reg2 reg3 = hcat [
2366         char '\t',
2367         ptext op,
2368         pprFSize sz,
2369         char '\t',
2370         pprReg reg1,
2371         ptext SLIT(", "),
2372         pprReg reg2,
2373         ptext SLIT(", "),
2374         pprReg reg3
2375     ]
2376
2377 pprRI :: RI -> Doc
2378 pprRI (RIReg r) = pprReg r
2379 pprRI (RIImm r) = pprImm r
2380
2381 pprFSize F64 = empty
2382 pprFSize F32 = char 's'
2383
2384     -- limit immediate argument for shift instruction to range 0..32
2385     -- (yes, the maximum is really 32, not 31)
2386 limitShiftRI :: RI -> RI
2387 limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32)
2388 limitShiftRI x = x
2389
2390 #endif /* powerpc_TARGET_ARCH */
2391
2392
2393 -- -----------------------------------------------------------------------------
2394 -- Converting floating-point literals to integrals for printing
2395
2396 #if __GLASGOW_HASKELL__ >= 504
2397 newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
2398 newFloatArray = newArray_
2399
2400 newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
2401 newDoubleArray = newArray_
2402
2403 castFloatToCharArray :: STUArray s Int Float -> ST s (STUArray s Int Word8)
2404 castFloatToCharArray = castSTUArray
2405
2406 castDoubleToCharArray :: STUArray s Int Double -> ST s (STUArray s Int Word8)
2407 castDoubleToCharArray = castSTUArray
2408
2409 writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
2410 writeFloatArray = writeArray
2411
2412 writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
2413 writeDoubleArray = writeArray
2414
2415 readCharArray :: STUArray s Int Word8 -> Int -> ST s Char
2416 readCharArray arr i = do
2417   w <- readArray arr i
2418   return $! (chr (fromIntegral w))
2419
2420 #else
2421
2422 castFloatToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2423 castFloatToCharArray = return
2424
2425 castDoubleToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2426
2427
2428 castDoubleToCharArray = return
2429
2430 #endif
2431
2432 -- floatToBytes and doubleToBytes convert to the host's byte
2433 -- order.  Providing that we're not cross-compiling for a
2434 -- target with the opposite endianness, this should work ok
2435 -- on all targets.
2436
2437 -- ToDo: this stuff is very similar to the shenanigans in PprAbs,
2438 -- could they be merged?
2439
2440 floatToBytes :: Float -> [Int]
2441 floatToBytes f
2442    = runST (do
2443         arr <- newFloatArray ((0::Int),3)
2444         writeFloatArray arr 0 f
2445         arr <- castFloatToCharArray arr
2446         i0 <- readCharArray arr 0
2447         i1 <- readCharArray arr 1
2448         i2 <- readCharArray arr 2
2449         i3 <- readCharArray arr 3
2450         return (map ord [i0,i1,i2,i3])
2451      )
2452
2453 doubleToBytes :: Double -> [Int]
2454 doubleToBytes d
2455    = runST (do
2456         arr <- newDoubleArray ((0::Int),7)
2457         writeDoubleArray arr 0 d
2458         arr <- castDoubleToCharArray arr
2459         i0 <- readCharArray arr 0
2460         i1 <- readCharArray arr 1
2461         i2 <- readCharArray arr 2
2462         i3 <- readCharArray arr 3
2463         i4 <- readCharArray arr 4
2464         i5 <- readCharArray arr 5
2465         i6 <- readCharArray arr 6
2466         i7 <- readCharArray arr 7
2467         return (map ord [i0,i1,i2,i3,i4,i5,i6,i7])
2468      )