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