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