compiler/nativeGen/PprMach.hs

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