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, pprPanic, ppr, docToSDoc)
  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 "ub"
 399         II16  -> sLit "uh"
 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 ".text\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 ".text\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  = let Just regH        = fPair reg
1890    in vcat [
1891        hcat [ptext (sLit "\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1892        hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg],
1893        hcat [pp_ld_lbracket, pprReg g1, ptext (sLit "+4]"), comma, pprReg regH],
1894        hcat [ptext (sLit "\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1895     ]
1896
1897 -- Translate to
1898 --    ld  [addr],%fn
1899 --    ld  [addr+4],%f(n+1)
1900 pprInstr (LD FF64 addr reg)
1901  = let  Just addr2      = addrOffset addr 4
1902         Just regH       = fPair reg
1903    in   vcat [
1904                hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
1905                hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg regH]
1906             ]
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  = let  Just regH       = fPair reg
1929    in vcat [
1930        hcat [ptext (sLit "\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1931        hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket,
1932              pprReg g1, rbrack],
1933        hcat [ptext (sLit "\tst\t"), pprReg regH, pp_comma_lbracket,
1934              pprReg g1, ptext (sLit "+4]")],
1935        hcat [ptext (sLit "\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1936     ]
1937
1938 -- Translate to
1939 --    st  %fn,[addr]
1940 --    st  %f(n+1),[addr+4]
1941 pprInstr instr@(ST FF64 reg addr)
1942  = let  Just addr2      = addrOffset addr 4
1943         Just regH       = fPair reg
1944    in   vcat [
1945               hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket,
1946                     pprAddr addr, rbrack],
1947               hcat [ptext (sLit "\tst\t"), pprReg regH, pp_comma_lbracket,
1948                     pprAddr addr2, rbrack]
1949             ]
1950
1951
1952
1953 -- no distinction is made between signed and unsigned bytes on stores for the
1954 -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
1955 -- so we call a special-purpose pprSize for ST..
1956
1957 pprInstr (ST size reg addr)
1958   = hcat [
1959        ptext (sLit "\tst"),
1960        pprStSize size,
1961        char '\t',
1962        pprReg reg,
1963        pp_comma_lbracket,
1964        pprAddr addr,
1965        rbrack
1966     ]
1967
1968 pprInstr (ADD x cc reg1 ri reg2)
1969   | not x && not cc && riZero ri
1970   = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1971
1972   | otherwise
1973   = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2
1974
1975 pprInstr (SUB x cc reg1 ri reg2)
1976   | not x && cc && reg2 == g0
1977   = hcat [ ptext (sLit "\tcmp\t"), pprReg reg1, comma, pprRI ri ]
1978   | not x && not cc && riZero ri
1979   = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1980   | otherwise
1981   = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2
1982
1983 pprInstr (AND  b reg1 ri reg2) = pprRegRIReg (sLit "and")  b reg1 ri reg2
1984 pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2
1985
1986 pprInstr (OR b reg1 ri reg2)
1987   | not b && reg1 == g0
1988   = let doit = hcat [ ptext (sLit "\tmov\t"), pprRI ri, comma, pprReg reg2 ]
1989     in  case ri of
1990            RIReg rrr | rrr == reg2 -> empty
1991            other                   -> doit
1992
1993   | otherwise
1994   = pprRegRIReg (sLit "or") b reg1 ri reg2
1995
1996 pprInstr (ORN b reg1 ri reg2) = pprRegRIReg (sLit "orn") b reg1 ri reg2
1997
1998 pprInstr (XOR  b reg1 ri reg2) = pprRegRIReg (sLit "xor")  b reg1 ri reg2
1999 pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg (sLit "xnor") b reg1 ri reg2
2000
2001 pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") False reg1 ri reg2
2002 pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") False reg1 ri reg2
2003 pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") False reg1 ri reg2
2004
2005 pprInstr (RDY rd) = ptext (sLit "\trd\t%y,") <> pprReg rd
2006 pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul")  b reg1 ri reg2
2007 pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul")  b reg1 ri reg2
2008
2009 pprInstr (SETHI imm reg)
2010   = hcat [
2011         ptext (sLit "\tsethi\t"),
2012         pprImm imm,
2013         comma,
2014         pprReg reg
2015     ]
2016
2017 pprInstr NOP = ptext (sLit "\tnop")
2018
2019 pprInstr (FABS FF32 reg1 reg2) = pprSizeRegReg (sLit "fabs") FF32 reg1 reg2
2020 pprInstr (FABS FF64 reg1 reg2)
2021  = let  Just reg1H      = fPair reg1
2022         Just reg2H      = fPair reg2
2023    in
2024     (<>) (pprSizeRegReg (sLit "fabs") FF32 reg1 reg2)
2025     (if (reg1 == reg2) then empty
2026      else (<>) (char '\n')
2027           (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
2028
2029 pprInstr (FADD size reg1 reg2 reg3)
2030   = pprSizeRegRegReg (sLit "fadd") size reg1 reg2 reg3
2031 pprInstr (FCMP e size reg1 reg2)
2032   = pprSizeRegReg (if e then sLit "fcmpe" else sLit "fcmp") size reg1 reg2
2033 pprInstr (FDIV size reg1 reg2 reg3)
2034   = pprSizeRegRegReg (sLit "fdiv") size reg1 reg2 reg3
2035
2036 pprInstr (FMOV FF32 reg1 reg2) = pprSizeRegReg (sLit "fmov") FF32 reg1 reg2
2037 pprInstr (FMOV FF64 reg1 reg2) = pprSizeRegReg (sLit "fmov") FF64 reg1 reg2
2038
2039 {-
2040 pprInstr (FMOV FF64 reg1 reg2)
2041  = let  Just reg1H      = fPair reg1
2042         Just reg2H      = fPair reg2
2043    in
2044     (<>) (pprSizeRegReg (sLit "fmov") FF32 reg1 reg2)
2045     (if (reg1 == reg2) then empty
2046      else (<>) (char '\n')
2047           (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
2048 -}
2049
2050 pprInstr (FMUL size reg1 reg2 reg3)
2051   = pprSizeRegRegReg (sLit "fmul") size reg1 reg2 reg3
2052
2053 pprInstr (FNEG FF32 reg1 reg2) = pprSizeRegReg (sLit "fneg") FF32 reg1 reg2
2054 pprInstr (FNEG FF64 reg1 reg2)
2055  = let  Just reg1H      = fPair reg1
2056         Just reg2H      = fPair reg2
2057    in
2058     (<>) (pprSizeRegReg (sLit "fneg") FF32 reg1 reg2)
2059     (if (reg1 == reg2) then empty
2060      else (<>) (char '\n')
2061           (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
2062
2063 pprInstr (FSQRT size reg1 reg2)     = pprSizeRegReg (sLit "fsqrt") size reg1 reg2
2064 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fsub") size reg1 reg2 reg3
2065 pprInstr (FxTOy size1 size2 reg1 reg2)
2066   = hcat [
2067         ptext (sLit "\tf"),
2068         ptext
2069         (case size1 of
2070             II32  -> sLit "ito"
2071             FF32  -> sLit "sto"
2072             FF64  -> sLit "dto"),
2073         ptext
2074         (case size2 of
2075             II32  -> sLit "i\t"
2076             FF32  -> sLit "s\t"
2077             FF64  -> sLit "d\t"),
2078         pprReg reg1, comma, pprReg reg2
2079     ]
2080
2081
2082 pprInstr (BI cond b (BlockId id))
2083   = hcat [
2084         ptext (sLit "\tb"), pprCond cond,
2085         if b then pp_comma_a else empty,
2086         char '\t',
2087         pprCLabel_asm (mkAsmTempLabel id)
2088     ]
2089
2090 pprInstr (BF cond b (BlockId id))
2091   = hcat [
2092         ptext (sLit "\tfb"), pprCond cond,
2093         if b then pp_comma_a else empty,
2094         char '\t',
2095         pprCLabel_asm (mkAsmTempLabel id)
2096     ]
2097
2098 pprInstr (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr addr)
2099
2100 pprInstr (CALL (Left imm) n _)
2101   = hcat [ ptext (sLit "\tcall\t"), pprImm imm, comma, int n ]
2102 pprInstr (CALL (Right reg) n _)
2103   = hcat [ ptext (sLit "\tcall\t"), pprReg reg, comma, int n ]
2104
2105 pprRI :: RI -> Doc
2106 pprRI (RIReg r) = pprReg r
2107 pprRI (RIImm r) = pprImm r
2108
2109 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
2110 pprSizeRegReg name size reg1 reg2
2111   = hcat [
2112         char '\t',
2113         ptext name,
2114         (case size of
2115             FF32 -> ptext (sLit "s\t")
2116             FF64 -> ptext (sLit "d\t")),
2117         pprReg reg1,
2118         comma,
2119         pprReg reg2
2120     ]
2121
2122 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
2123 pprSizeRegRegReg name size reg1 reg2 reg3
2124   = hcat [
2125         char '\t',
2126         ptext name,
2127         (case size of
2128             FF32  -> ptext (sLit "s\t")
2129             FF64  -> ptext (sLit "d\t")),
2130         pprReg reg1,
2131         comma,
2132         pprReg reg2,
2133         comma,
2134         pprReg reg3
2135     ]
2136
2137 pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
2138 pprRegRIReg name b reg1 ri reg2
2139   = hcat [
2140         char '\t',
2141         ptext name,
2142         if b then ptext (sLit "cc\t") else char '\t',
2143         pprReg reg1,
2144         comma,
2145         pprRI ri,
2146         comma,
2147         pprReg reg2
2148     ]
2149
2150 pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
2151 pprRIReg name b ri reg1
2152   = hcat [
2153         char '\t',
2154         ptext name,
2155         if b then ptext (sLit "cc\t") else char '\t',
2156         pprRI ri,
2157         comma,
2158         pprReg reg1
2159     ]
2160
2161 pp_ld_lbracket    = ptext (sLit "\tld\t[")
2162 pp_rbracket_comma = text "],"
2163 pp_comma_lbracket = text ",["
2164 pp_comma_a        = text ",a"
2165
2166 #endif /* sparc_TARGET_ARCH */
2167
2168
2169 -- -----------------------------------------------------------------------------
2170 -- pprInstr for PowerPC
2171
2172 #if powerpc_TARGET_ARCH
2173
2174 pprInstr (SPILL reg slot)
2175    = hcat [
2176         ptext (sLit "\tSPILL"),
2177         char '\t',
2178         pprReg reg,
2179         comma,
2180         ptext (sLit "SLOT") <> parens (int slot)]
2181
2182 pprInstr (RELOAD slot reg)
2183    = hcat [
2184         ptext (sLit "\tRELOAD"),
2185         char '\t',
2186         ptext (sLit "SLOT") <> parens (int slot),
2187         comma,
2188         pprReg reg]
2189
2190 pprInstr (LD sz reg addr) = hcat [
2191         char '\t',
2192         ptext (sLit "l"),
2193         ptext (case sz of
2194             II8  -> sLit "bz"
2195             II16 -> sLit "hz"
2196             II32 -> sLit "wz"
2197             FF32 -> sLit "fs"
2198             FF64 -> sLit "fd"),
2199         case addr of AddrRegImm _ _ -> empty
2200                      AddrRegReg _ _ -> char 'x',
2201         char '\t',
2202         pprReg reg,
2203         ptext (sLit ", "),
2204         pprAddr addr
2205     ]
2206 pprInstr (LA sz reg addr) = hcat [
2207         char '\t',
2208         ptext (sLit "l"),
2209         ptext (case sz of
2210             II8  -> sLit "ba"
2211             II16 -> sLit "ha"
2212             II32 -> sLit "wa"
2213             FF32 -> sLit "fs"
2214             FF64 -> sLit "fd"),
2215         case addr of AddrRegImm _ _ -> empty
2216                      AddrRegReg _ _ -> char 'x',
2217         char '\t',
2218         pprReg reg,
2219         ptext (sLit ", "),
2220         pprAddr addr
2221     ]
2222 pprInstr (ST sz reg addr) = hcat [
2223         char '\t',
2224         ptext (sLit "st"),
2225         pprSize sz,
2226         case addr of AddrRegImm _ _ -> empty
2227                      AddrRegReg _ _ -> char 'x',
2228         char '\t',
2229         pprReg reg,
2230         ptext (sLit ", "),
2231         pprAddr addr
2232     ]
2233 pprInstr (STU sz reg addr) = hcat [
2234         char '\t',
2235         ptext (sLit "st"),
2236         pprSize sz,
2237         ptext (sLit "u\t"),
2238         case addr of AddrRegImm _ _ -> empty
2239                      AddrRegReg _ _ -> char 'x',
2240         pprReg reg,
2241         ptext (sLit ", "),
2242         pprAddr addr
2243     ]
2244 pprInstr (LIS reg imm) = hcat [
2245         char '\t',
2246         ptext (sLit "lis"),
2247         char '\t',
2248         pprReg reg,
2249         ptext (sLit ", "),
2250         pprImm imm
2251     ]
2252 pprInstr (LI reg imm) = hcat [
2253         char '\t',
2254         ptext (sLit "li"),
2255         char '\t',
2256         pprReg reg,
2257         ptext (sLit ", "),
2258         pprImm imm
2259     ]
2260 pprInstr (MR reg1 reg2)
2261     | reg1 == reg2 = empty
2262     | otherwise = hcat [
2263         char '\t',
2264         case regClass reg1 of
2265             RcInteger -> ptext (sLit "mr")
2266             _ -> ptext (sLit "fmr"),
2267         char '\t',
2268         pprReg reg1,
2269         ptext (sLit ", "),
2270         pprReg reg2
2271     ]
2272 pprInstr (CMP sz reg ri) = hcat [
2273         char '\t',
2274         op,
2275         char '\t',
2276         pprReg reg,
2277         ptext (sLit ", "),
2278         pprRI ri
2279     ]
2280     where
2281         op = hcat [
2282                 ptext (sLit "cmp"),
2283                 pprSize sz,
2284                 case ri of
2285                     RIReg _ -> empty
2286                     RIImm _ -> char 'i'
2287             ]
2288 pprInstr (CMPL sz reg ri) = hcat [
2289         char '\t',
2290         op,
2291         char '\t',
2292         pprReg reg,
2293         ptext (sLit ", "),
2294         pprRI ri
2295     ]
2296     where
2297         op = hcat [
2298                 ptext (sLit "cmpl"),
2299                 pprSize sz,
2300                 case ri of
2301                     RIReg _ -> empty
2302                     RIImm _ -> char 'i'
2303             ]
2304 pprInstr (BCC cond (BlockId id)) = hcat [
2305         char '\t',
2306         ptext (sLit "b"),
2307         pprCond cond,
2308         char '\t',
2309         pprCLabel_asm lbl
2310     ]
2311     where lbl = mkAsmTempLabel id
2312
2313 pprInstr (BCCFAR cond (BlockId id)) = vcat [
2314         hcat [
2315             ptext (sLit "\tb"),
2316             pprCond (condNegate cond),
2317             ptext (sLit "\t$+8")
2318         ],
2319         hcat [
2320             ptext (sLit "\tb\t"),
2321             pprCLabel_asm lbl
2322         ]
2323     ]
2324     where lbl = mkAsmTempLabel id
2325
2326 pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
2327         char '\t',
2328         ptext (sLit "b"),
2329         char '\t',
2330         pprCLabel_asm lbl
2331     ]
2332
2333 pprInstr (MTCTR reg) = hcat [
2334         char '\t',
2335         ptext (sLit "mtctr"),
2336         char '\t',
2337         pprReg reg
2338     ]
2339 pprInstr (BCTR _) = hcat [
2340         char '\t',
2341         ptext (sLit "bctr")
2342     ]
2343 pprInstr (BL lbl _) = hcat [
2344         ptext (sLit "\tbl\t"),
2345         pprCLabel_asm lbl
2346     ]
2347 pprInstr (BCTRL _) = hcat [
2348         char '\t',
2349         ptext (sLit "bctrl")
2350     ]
2351 pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri
2352 pprInstr (ADDIS reg1 reg2 imm) = hcat [
2353         char '\t',
2354         ptext (sLit "addis"),
2355         char '\t',
2356         pprReg reg1,
2357         ptext (sLit ", "),
2358         pprReg reg2,
2359         ptext (sLit ", "),
2360         pprImm imm
2361     ]
2362
2363 pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3)
2364 pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3)
2365 pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3)
2366 pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri
2367 pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri
2368 pprInstr (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3)
2369 pprInstr (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3)
2370
2371 pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
2372          hcat [ ptext (sLit "\tmullwo\t"), pprReg reg1, ptext (sLit ", "),
2373                                           pprReg reg2, ptext (sLit ", "),
2374                                           pprReg reg3 ],
2375          hcat [ ptext (sLit "\tmfxer\t"),  pprReg reg1 ],
2376          hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "),
2377                                           pprReg reg1, ptext (sLit ", "),
2378                                           ptext (sLit "2, 31, 31") ]
2379     ]
2380
2381         -- for some reason, "andi" doesn't exist.
2382         -- we'll use "andi." instead.
2383 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
2384         char '\t',
2385         ptext (sLit "andi."),
2386         char '\t',
2387         pprReg reg1,
2388         ptext (sLit ", "),
2389         pprReg reg2,
2390         ptext (sLit ", "),
2391         pprImm imm
2392     ]
2393 pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri
2394
2395 pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri
2396 pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri
2397
2398 pprInstr (XORIS reg1 reg2 imm) = hcat [
2399         char '\t',
2400         ptext (sLit "xoris"),
2401         char '\t',
2402         pprReg reg1,
2403         ptext (sLit ", "),
2404         pprReg reg2,
2405         ptext (sLit ", "),
2406         pprImm imm
2407     ]
2408
2409 pprInstr (EXTS sz reg1 reg2) = hcat [
2410         char '\t',
2411         ptext (sLit "exts"),
2412         pprSize sz,
2413         char '\t',
2414         pprReg reg1,
2415         ptext (sLit ", "),
2416         pprReg reg2
2417     ]
2418
2419 pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2
2420 pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2
2421
2422 pprInstr (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri)
2423 pprInstr (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri)
2424 pprInstr (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri)
2425 pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
2426         ptext (sLit "\trlwinm\t"),
2427         pprReg reg1,
2428         ptext (sLit ", "),
2429         pprReg reg2,
2430         ptext (sLit ", "),
2431         int sh,
2432         ptext (sLit ", "),
2433         int mb,
2434         ptext (sLit ", "),
2435         int me
2436     ]
2437
2438 pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF (sLit "fadd") sz reg1 reg2 reg3
2439 pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF (sLit "fsub") sz reg1 reg2 reg3
2440 pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF (sLit "fmul") sz reg1 reg2 reg3
2441 pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") sz reg1 reg2 reg3
2442 pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2
2443
2444 pprInstr (FCMP reg1 reg2) = hcat [
2445         char '\t',
2446         ptext (sLit "fcmpu\tcr0, "),
2447             -- Note: we're using fcmpu, not fcmpo
2448             -- The difference is with fcmpo, compare with NaN is an invalid operation.
2449             -- We don't handle invalid fp ops, so we don't care
2450         pprReg reg1,
2451         ptext (sLit ", "),
2452         pprReg reg2
2453     ]
2454
2455 pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2
2456 pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2
2457
2458 pprInstr (CRNOR dst src1 src2) = hcat [
2459         ptext (sLit "\tcrnor\t"),
2460         int dst,
2461         ptext (sLit ", "),
2462         int src1,
2463         ptext (sLit ", "),
2464         int src2
2465     ]
2466
2467 pprInstr (MFCR reg) = hcat [
2468         char '\t',
2469         ptext (sLit "mfcr"),
2470         char '\t',
2471         pprReg reg
2472     ]
2473
2474 pprInstr (MFLR reg) = hcat [
2475         char '\t',
2476         ptext (sLit "mflr"),
2477         char '\t',
2478         pprReg reg
2479     ]
2480
2481 pprInstr (FETCHPC reg) = vcat [
2482         ptext (sLit "\tbcl\t20,31,1f"),
2483         hcat [ ptext (sLit "1:\tmflr\t"), pprReg reg ]
2484     ]
2485
2486 pprInstr LWSYNC = ptext (sLit "\tlwsync")
2487
2488 pprInstr _ = panic "pprInstr (ppc)"
2489
2490 pprLogic op reg1 reg2 ri = hcat [
2491         char '\t',
2492         ptext op,
2493         case ri of
2494             RIReg _ -> empty
2495             RIImm _ -> char 'i',
2496         char '\t',
2497         pprReg reg1,
2498         ptext (sLit ", "),
2499         pprReg reg2,
2500         ptext (sLit ", "),
2501         pprRI ri
2502     ]
2503
2504 pprUnary op reg1 reg2 = hcat [
2505         char '\t',
2506         ptext op,
2507         char '\t',
2508         pprReg reg1,
2509         ptext (sLit ", "),
2510         pprReg reg2
2511     ]
2512
2513 pprBinaryF op sz reg1 reg2 reg3 = hcat [
2514         char '\t',
2515         ptext op,
2516         pprFSize sz,
2517         char '\t',
2518         pprReg reg1,
2519         ptext (sLit ", "),
2520         pprReg reg2,
2521         ptext (sLit ", "),
2522         pprReg reg3
2523     ]
2524
2525 pprRI :: RI -> Doc
2526 pprRI (RIReg r) = pprReg r
2527 pprRI (RIImm r) = pprImm r
2528
2529 pprFSize FF64 = empty
2530 pprFSize FF32 = char 's'
2531
2532     -- limit immediate argument for shift instruction to range 0..32
2533     -- (yes, the maximum is really 32, not 31)
2534 limitShiftRI :: RI -> RI
2535 limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32)
2536 limitShiftRI x = x
2537
2538 #endif /* powerpc_TARGET_ARCH */
2539
2540
2541 -- -----------------------------------------------------------------------------
2542 -- Converting floating-point literals to integrals for printing
2543
2544 castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)
2545 castFloatToWord8Array = castSTUArray
2546
2547 castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8)
2548 castDoubleToWord8Array = castSTUArray
2549
2550 -- floatToBytes and doubleToBytes convert to the host's byte
2551 -- order.  Providing that we're not cross-compiling for a
2552 -- target with the opposite endianness, this should work ok
2553 -- on all targets.
2554
2555 -- ToDo: this stuff is very similar to the shenanigans in PprAbs,
2556 -- could they be merged?
2557
2558 floatToBytes :: Float -> [Int]
2559 floatToBytes f
2560    = runST (do
2561         arr <- newArray_ ((0::Int),3)
2562         writeArray arr 0 f
2563         arr <- castFloatToWord8Array arr
2564         i0 <- readArray arr 0
2565         i1 <- readArray arr 1
2566         i2 <- readArray arr 2
2567         i3 <- readArray arr 3
2568         return (map fromIntegral [i0,i1,i2,i3])
2569      )
2570
2571 doubleToBytes :: Double -> [Int]
2572 doubleToBytes d
2573    = runST (do
2574         arr <- newArray_ ((0::Int),7)
2575         writeArray arr 0 d
2576         arr <- castDoubleToWord8Array arr
2577         i0 <- readArray arr 0
2578         i1 <- readArray arr 1
2579         i2 <- readArray arr 2
2580         i3 <- readArray arr 3
2581         i4 <- readArray arr 4
2582         i5 <- readArray arr 5
2583         i6 <- readArray arr 6
2584         i7 <- readArray arr 7
2585         return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7])
2586      )