compiler/nativeGen/PprMach.hs

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