ghc/compiler/nativeGen/PprMach.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996-1998
   3 %
   4 \section[PprMach]{Pretty-printing assembly language}
   5
   6 We start with the @pprXXX@s with some cross-platform commonality
   7 (e.g., @pprReg@); we conclude with the no-commonality monster,
   8 @pprInstr@.
   9
  10 \begin{code}
  11 #include "nativeGen/NCG.h"
  12
  13 module PprMach ( pprInstr, pprSize, pprUserReg ) where
  14
  15 #include "HsVersions.h"
  16
  17 import MachRegs         -- may differ per-platform
  18 import MachMisc
  19
  20 import CLabel           ( pprCLabel, externallyVisibleCLabel, labelDynamic )
  21 import Stix             ( CodeSegment(..) )
  22 import Unique           ( pprUnique )
  23 import Panic            ( panic )
  24 import Pretty
  25 import FastString
  26 import qualified Outputable
  27
  28 #if __GLASGOW_HASKELL__ >= 504
  29 import Data.Array.ST
  30 import Data.Word        ( Word8 )
  31 #else
  32 import MutableArray
  33 #endif
  34
  35 import MONAD_ST
  36
  37 import Char             ( chr, ord )
  38 import Maybe            ( isJust )
  39
  40 asmSDoc d = Outputable.withPprStyleDoc (
  41               Outputable.mkCodeStyle Outputable.AsmStyle) d
  42 pprCLabel_asm l = asmSDoc (pprCLabel l)
  43 \end{code}
  44
  45 %************************************************************************
  46 %*                                                                      *
  47 \subsection{@pprReg@: print a @Reg@}
  48 %*                                                                      *
  49 %************************************************************************
  50
  51 For x86, the way we print a register name depends
  52 on which bit of it we care about.  Yurgh.
  53 \begin{code}
  54 pprUserReg :: Reg -> Doc
  55 pprUserReg = pprReg IF_ARCH_i386(L,)
  56
  57 pprReg :: IF_ARCH_i386(Size ->,) Reg -> Doc
  58
  59 pprReg IF_ARCH_i386(s,) r
  60   = case r of
  61       RealReg i      -> ppr_reg_no IF_ARCH_i386(s,) i
  62       VirtualRegI u  -> text "%vI_" <> asmSDoc (pprVRegUnique u)
  63       VirtualRegF u  -> text "%vF_" <> asmSDoc (pprVRegUnique u)
  64   where
  65 #if alpha_TARGET_ARCH
  66     ppr_reg_no :: Int -> Doc
  67     ppr_reg_no i = ptext
  68       (case i of {
  69          0 -> SLIT("$0");    1 -> SLIT("$1");
  70          2 -> SLIT("$2");    3 -> SLIT("$3");
  71          4 -> SLIT("$4");    5 -> SLIT("$5");
  72          6 -> SLIT("$6");    7 -> SLIT("$7");
  73          8 -> SLIT("$8");    9 -> SLIT("$9");
  74         10 -> SLIT("$10");  11 -> SLIT("$11");
  75         12 -> SLIT("$12");  13 -> SLIT("$13");
  76         14 -> SLIT("$14");  15 -> SLIT("$15");
  77         16 -> SLIT("$16");  17 -> SLIT("$17");
  78         18 -> SLIT("$18");  19 -> SLIT("$19");
  79         20 -> SLIT("$20");  21 -> SLIT("$21");
  80         22 -> SLIT("$22");  23 -> SLIT("$23");
  81         24 -> SLIT("$24");  25 -> SLIT("$25");
  82         26 -> SLIT("$26");  27 -> SLIT("$27");
  83         28 -> SLIT("$28");  29 -> SLIT("$29");
  84         30 -> SLIT("$30");  31 -> SLIT("$31");
  85         32 -> SLIT("$f0");  33 -> SLIT("$f1");
  86         34 -> SLIT("$f2");  35 -> SLIT("$f3");
  87         36 -> SLIT("$f4");  37 -> SLIT("$f5");
  88         38 -> SLIT("$f6");  39 -> SLIT("$f7");
  89         40 -> SLIT("$f8");  41 -> SLIT("$f9");
  90         42 -> SLIT("$f10"); 43 -> SLIT("$f11");
  91         44 -> SLIT("$f12"); 45 -> SLIT("$f13");
  92         46 -> SLIT("$f14"); 47 -> SLIT("$f15");
  93         48 -> SLIT("$f16"); 49 -> SLIT("$f17");
  94         50 -> SLIT("$f18"); 51 -> SLIT("$f19");
  95         52 -> SLIT("$f20"); 53 -> SLIT("$f21");
  96         54 -> SLIT("$f22"); 55 -> SLIT("$f23");
  97         56 -> SLIT("$f24"); 57 -> SLIT("$f25");
  98         58 -> SLIT("$f26"); 59 -> SLIT("$f27");
  99         60 -> SLIT("$f28"); 61 -> SLIT("$f29");
 100         62 -> SLIT("$f30"); 63 -> SLIT("$f31");
 101         _  -> SLIT("very naughty alpha register")
 102       })
 103 #endif
 104 #if i386_TARGET_ARCH
 105     ppr_reg_no :: Size -> Int -> Doc
 106     ppr_reg_no B  = ppr_reg_byte
 107     ppr_reg_no Bu = ppr_reg_byte
 108     ppr_reg_no W  = ppr_reg_word
 109     ppr_reg_no Wu = ppr_reg_word
 110     ppr_reg_no _  = ppr_reg_long
 111
 112     ppr_reg_byte i = ptext
 113       (case i of {
 114          0 -> SLIT("%al");     1 -> SLIT("%bl");
 115          2 -> SLIT("%cl");     3 -> SLIT("%dl");
 116         _  -> SLIT("very naughty I386 byte register")
 117       })
 118
 119     ppr_reg_word i = ptext
 120       (case i of {
 121          0 -> SLIT("%ax");     1 -> SLIT("%bx");
 122          2 -> SLIT("%cx");     3 -> SLIT("%dx");
 123          4 -> SLIT("%si");     5 -> SLIT("%di");
 124          6 -> SLIT("%bp");     7 -> SLIT("%sp");
 125         _  -> SLIT("very naughty I386 word register")
 126       })
 127
 128     ppr_reg_long i = ptext
 129       (case i of {
 130          0 -> SLIT("%eax");    1 -> SLIT("%ebx");
 131          2 -> SLIT("%ecx");    3 -> SLIT("%edx");
 132          4 -> SLIT("%esi");    5 -> SLIT("%edi");
 133          6 -> SLIT("%ebp");    7 -> SLIT("%esp");
 134          8 -> SLIT("%fake0");  9 -> SLIT("%fake1");
 135         10 -> SLIT("%fake2"); 11 -> SLIT("%fake3");
 136         12 -> SLIT("%fake4"); 13 -> SLIT("%fake5");
 137         _  -> SLIT("very naughty I386 register")
 138       })
 139 #endif
 140 #if sparc_TARGET_ARCH
 141     ppr_reg_no :: Int -> Doc
 142     ppr_reg_no i = ptext
 143       (case i of {
 144          0 -> SLIT("%g0");   1 -> SLIT("%g1");
 145          2 -> SLIT("%g2");   3 -> SLIT("%g3");
 146          4 -> SLIT("%g4");   5 -> SLIT("%g5");
 147          6 -> SLIT("%g6");   7 -> SLIT("%g7");
 148          8 -> SLIT("%o0");   9 -> SLIT("%o1");
 149         10 -> SLIT("%o2");  11 -> SLIT("%o3");
 150         12 -> SLIT("%o4");  13 -> SLIT("%o5");
 151         14 -> SLIT("%o6");  15 -> SLIT("%o7");
 152         16 -> SLIT("%l0");  17 -> SLIT("%l1");
 153         18 -> SLIT("%l2");  19 -> SLIT("%l3");
 154         20 -> SLIT("%l4");  21 -> SLIT("%l5");
 155         22 -> SLIT("%l6");  23 -> SLIT("%l7");
 156         24 -> SLIT("%i0");  25 -> SLIT("%i1");
 157         26 -> SLIT("%i2");  27 -> SLIT("%i3");
 158         28 -> SLIT("%i4");  29 -> SLIT("%i5");
 159         30 -> SLIT("%i6");  31 -> SLIT("%i7");
 160         32 -> SLIT("%f0");  33 -> SLIT("%f1");
 161         34 -> SLIT("%f2");  35 -> SLIT("%f3");
 162         36 -> SLIT("%f4");  37 -> SLIT("%f5");
 163         38 -> SLIT("%f6");  39 -> SLIT("%f7");
 164         40 -> SLIT("%f8");  41 -> SLIT("%f9");
 165         42 -> SLIT("%f10"); 43 -> SLIT("%f11");
 166         44 -> SLIT("%f12"); 45 -> SLIT("%f13");
 167         46 -> SLIT("%f14"); 47 -> SLIT("%f15");
 168         48 -> SLIT("%f16"); 49 -> SLIT("%f17");
 169         50 -> SLIT("%f18"); 51 -> SLIT("%f19");
 170         52 -> SLIT("%f20"); 53 -> SLIT("%f21");
 171         54 -> SLIT("%f22"); 55 -> SLIT("%f23");
 172         56 -> SLIT("%f24"); 57 -> SLIT("%f25");
 173         58 -> SLIT("%f26"); 59 -> SLIT("%f27");
 174         60 -> SLIT("%f28"); 61 -> SLIT("%f29");
 175         62 -> SLIT("%f30"); 63 -> SLIT("%f31");
 176         _  -> SLIT("very naughty sparc register")
 177       })
 178 #endif
 179 #if powerpc_TARGET_ARCH
 180     ppr_reg_no :: Int -> Doc
 181     ppr_reg_no i = ptext
 182       (case i of {
 183          0 -> SLIT("r0");   1 -> SLIT("r1");
 184          2 -> SLIT("r2");   3 -> SLIT("r3");
 185          4 -> SLIT("r4");   5 -> SLIT("r5");
 186          6 -> SLIT("r6");   7 -> SLIT("r7");
 187          8 -> SLIT("r8");   9 -> SLIT("r9");
 188         10 -> SLIT("r10");  11 -> SLIT("r11");
 189         12 -> SLIT("r12");  13 -> SLIT("r13");
 190         14 -> SLIT("r14");  15 -> SLIT("r15");
 191         16 -> SLIT("r16");  17 -> SLIT("r17");
 192         18 -> SLIT("r18");  19 -> SLIT("r19");
 193         20 -> SLIT("r20");  21 -> SLIT("r21");
 194         22 -> SLIT("r22");  23 -> SLIT("r23");
 195         24 -> SLIT("r24");  25 -> SLIT("r25");
 196         26 -> SLIT("r26");  27 -> SLIT("r27");
 197         28 -> SLIT("r28");  29 -> SLIT("r29");
 198         30 -> SLIT("r30");  31 -> SLIT("r31");
 199         32 -> SLIT("f0");  33 -> SLIT("f1");
 200         34 -> SLIT("f2");  35 -> SLIT("f3");
 201         36 -> SLIT("f4");  37 -> SLIT("f5");
 202         38 -> SLIT("f6");  39 -> SLIT("f7");
 203         40 -> SLIT("f8");  41 -> SLIT("f9");
 204         42 -> SLIT("f10"); 43 -> SLIT("f11");
 205         44 -> SLIT("f12"); 45 -> SLIT("f13");
 206         46 -> SLIT("f14"); 47 -> SLIT("f15");
 207         48 -> SLIT("f16"); 49 -> SLIT("f17");
 208         50 -> SLIT("f18"); 51 -> SLIT("f19");
 209         52 -> SLIT("f20"); 53 -> SLIT("f21");
 210         54 -> SLIT("f22"); 55 -> SLIT("f23");
 211         56 -> SLIT("f24"); 57 -> SLIT("f25");
 212         58 -> SLIT("f26"); 59 -> SLIT("f27");
 213         60 -> SLIT("f28"); 61 -> SLIT("f29");
 214         62 -> SLIT("f30"); 63 -> SLIT("f31");
 215         _  -> SLIT("very naughty powerpc register")
 216       })
 217 #endif
 218 \end{code}
 219
 220 %************************************************************************
 221 %*                                                                      *
 222 \subsection{@pprSize@: print a @Size@}
 223 %*                                                                      *
 224 %************************************************************************
 225
 226 \begin{code}
 227 pprSize :: Size -> Doc
 228
 229 pprSize x = ptext (case x of
 230 #if alpha_TARGET_ARCH
 231          B  -> SLIT("b")
 232          Bu -> SLIT("bu")
 233 --       W  -> SLIT("w") UNUSED
 234 --       Wu -> SLIT("wu") UNUSED
 235          L  -> SLIT("l")
 236          Q  -> SLIT("q")
 237 --       FF -> SLIT("f") UNUSED
 238 --       DF -> SLIT("d") UNUSED
 239 --       GF -> SLIT("g") UNUSED
 240 --       SF -> SLIT("s") UNUSED
 241          TF -> SLIT("t")
 242 #endif
 243 #if i386_TARGET_ARCH
 244         B   -> SLIT("b")
 245         Bu  -> SLIT("b")
 246         W   -> SLIT("w")
 247         Wu  -> SLIT("w")
 248         L   -> SLIT("l")
 249         Lu  -> SLIT("l")
 250         F   -> SLIT("s")
 251         DF  -> SLIT("l")
 252         F80 -> SLIT("t")
 253 #endif
 254 #if sparc_TARGET_ARCH
 255         B   -> SLIT("sb")
 256         Bu  -> SLIT("ub")
 257         H   -> SLIT("sh")
 258         Hu  -> SLIT("uh")
 259         W   -> SLIT("")
 260         F   -> SLIT("")
 261         DF  -> SLIT("d")
 262     )
 263 pprStSize :: Size -> Doc
 264 pprStSize x = ptext (case x of
 265         B   -> SLIT("b")
 266         Bu  -> SLIT("b")
 267         H   -> SLIT("h")
 268         Hu  -> SLIT("h")
 269         W   -> SLIT("")
 270         F   -> SLIT("")
 271         DF  -> SLIT("d")
 272 #endif
 273 #if powerpc_TARGET_ARCH
 274         B   -> SLIT("b")
 275         Bu  -> SLIT("b")
 276         H   -> SLIT("h")
 277         Hu  -> SLIT("h")
 278         W   -> SLIT("w")
 279         F   -> SLIT("fs")
 280         DF  -> SLIT("fd")
 281 #endif
 282     )
 283 \end{code}
 284
 285 %************************************************************************
 286 %*                                                                      *
 287 \subsection{@pprCond@: print a @Cond@}
 288 %*                                                                      *
 289 %************************************************************************
 290
 291 \begin{code}
 292 pprCond :: Cond -> Doc
 293
 294 pprCond c = ptext (case c of {
 295 #if alpha_TARGET_ARCH
 296         EQQ  -> SLIT("eq");
 297         LTT  -> SLIT("lt");
 298         LE  -> SLIT("le");
 299         ULT -> SLIT("ult");
 300         ULE -> SLIT("ule");
 301         NE  -> SLIT("ne");
 302         GTT  -> SLIT("gt");
 303         GE  -> SLIT("ge")
 304 #endif
 305 #if i386_TARGET_ARCH
 306         GEU     -> SLIT("ae");  LU    -> SLIT("b");
 307         EQQ     -> SLIT("e");   GTT    -> SLIT("g");
 308         GE      -> SLIT("ge");  GU    -> SLIT("a");
 309         LTT     -> SLIT("l");   LE    -> SLIT("le");
 310         LEU     -> SLIT("be");  NE    -> SLIT("ne");
 311         NEG     -> SLIT("s");   POS   -> SLIT("ns");
 312         CARRY   -> SLIT("c");   OFLO  -> SLIT("o");
 313         ALWAYS  -> SLIT("mp")   -- hack
 314 #endif
 315 #if sparc_TARGET_ARCH
 316         ALWAYS  -> SLIT("");    NEVER -> SLIT("n");
 317         GEU     -> SLIT("geu"); LU    -> SLIT("lu");
 318         EQQ     -> SLIT("e");   GTT   -> SLIT("g");
 319         GE      -> SLIT("ge");  GU    -> SLIT("gu");
 320         LTT     -> SLIT("l");   LE    -> SLIT("le");
 321         LEU     -> SLIT("leu"); NE    -> SLIT("ne");
 322         NEG     -> SLIT("neg"); POS   -> SLIT("pos");
 323         VC      -> SLIT("vc");  VS    -> SLIT("vs")
 324 #endif
 325 #if powerpc_TARGET_ARCH
 326         ALWAYS  -> SLIT("");
 327         EQQ     -> SLIT("eq");  NE    -> SLIT("ne");
 328         LTT     -> SLIT("lt");  GE    -> SLIT("ge");
 329         GTT     -> SLIT("gt");  LE    -> SLIT("le");
 330         LU      -> SLIT("lt");  GEU   -> SLIT("ge");
 331         GU      -> SLIT("gt");  LEU   -> SLIT("le");
 332 #endif
 333     })
 334 \end{code}
 335
 336 %************************************************************************
 337 %*                                                                      *
 338 \subsection{@pprImm@: print an @Imm@}
 339 %*                                                                      *
 340 %************************************************************************
 341
 342 \begin{code}
 343 pprImm :: Imm -> Doc
 344
 345 pprImm (ImmInt i)     = int i
 346 pprImm (ImmInteger i) = integer i
 347 pprImm (ImmCLbl l)    = (if labelDynamic l then text "__imp_" else empty)
 348                         <> pprCLabel_asm l
 349 pprImm (ImmIndex l i) = (if labelDynamic l then text "__imp_" else empty)
 350                         <> pprCLabel_asm l <> char '+' <> int i
 351 pprImm (ImmLit s)     = s
 352
 353 pprImm (ImmLab dll s) = (if underscorePrefix then char '_' else empty)
 354                         <> (if dll then text "_imp__" else empty)
 355                         <> s
 356
 357 #if sparc_TARGET_ARCH
 358 pprImm (LO i)
 359   = hcat [ pp_lo, pprImm i, rparen ]
 360   where
 361     pp_lo = text "%lo("
 362
 363 pprImm (HI i)
 364   = hcat [ pp_hi, pprImm i, rparen ]
 365   where
 366     pp_hi = text "%hi("
 367 #endif
 368 #if powerpc_TARGET_ARCH
 369 pprImm (LO i)
 370   = hcat [ pp_lo, pprImm i, rparen ]
 371   where
 372     pp_lo = text "lo16("
 373
 374 pprImm (HI i)
 375   = hcat [ pp_hi, pprImm i, rparen ]
 376   where
 377     pp_hi = text "hi16("
 378
 379 pprImm (HA i)
 380   = hcat [ pp_ha, pprImm i, rparen ]
 381   where
 382     pp_ha = text "ha16("
 383 #endif
 384 \end{code}
 385
 386 %************************************************************************
 387 %*                                                                      *
 388 \subsection{@pprAddr@: print an @Addr@}
 389 %*                                                                      *
 390 %************************************************************************
 391
 392 \begin{code}
 393 pprAddr :: MachRegsAddr -> Doc
 394
 395 #if alpha_TARGET_ARCH
 396 pprAddr (AddrReg r) = parens (pprReg r)
 397 pprAddr (AddrImm i) = pprImm i
 398 pprAddr (AddrRegImm r1 i)
 399   = (<>) (pprImm i) (parens (pprReg r1))
 400 #endif
 401
 402 -------------------
 403
 404 #if i386_TARGET_ARCH
 405 pprAddr (ImmAddr imm off)
 406   = let pp_imm = pprImm imm
 407     in
 408     if (off == 0) then
 409         pp_imm
 410     else if (off < 0) then
 411         pp_imm <> int off
 412     else
 413         pp_imm <> char '+' <> int off
 414
 415 pprAddr (AddrBaseIndex base index displacement)
 416   = let
 417         pp_disp  = ppr_disp displacement
 418         pp_off p = pp_disp <> char '(' <> p <> char ')'
 419         pp_reg r = pprReg L r
 420     in
 421     case (base,index) of
 422       (Nothing, Nothing)    -> pp_disp
 423       (Just b,  Nothing)    -> pp_off (pp_reg b)
 424       (Nothing, Just (r,i)) -> pp_off (pp_reg r <> comma <> int i)
 425       (Just b,  Just (r,i)) -> pp_off (pp_reg b <> comma <> pp_reg r
 426                                        <> comma <> int i)
 427   where
 428     ppr_disp (ImmInt 0) = empty
 429     ppr_disp imm        = pprImm imm
 430 #endif
 431
 432 -------------------
 433
 434 #if sparc_TARGET_ARCH
 435 pprAddr (AddrRegReg r1 (RealReg 0)) = pprReg r1
 436
 437 pprAddr (AddrRegReg r1 r2)
 438   = hcat [ pprReg r1, char '+', pprReg r2 ]
 439
 440 pprAddr (AddrRegImm r1 (ImmInt i))
 441   | i == 0 = pprReg r1
 442   | not (fits13Bits i) = largeOffsetError i
 443   | otherwise = hcat [ pprReg r1, pp_sign, int i ]
 444   where
 445     pp_sign = if i > 0 then char '+' else empty
 446
 447 pprAddr (AddrRegImm r1 (ImmInteger i))
 448   | i == 0 = pprReg r1
 449   | not (fits13Bits i) = largeOffsetError i
 450 -------------------
 451
 452   | otherwise  = hcat [ pprReg r1, pp_sign, integer i ]
 453   where
 454     pp_sign = if i > 0 then char '+' else empty
 455
 456 pprAddr (AddrRegImm r1 imm)
 457   = hcat [ pprReg r1, char '+', pprImm imm ]
 458 #endif
 459 #if powerpc_TARGET_ARCH
 460 pprAddr (AddrRegReg r1 r2)
 461   = error "PprMach.pprAddr (AddrRegReg) unimplemented"
 462
 463 pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ]
 464 pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ]
 465 pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]
 466 #endif
 467 \end{code}
 468
 469 %************************************************************************
 470 %*                                                                      *
 471 \subsection{@pprInstr@: print an @Instr@}
 472 %*                                                                      *
 473 %************************************************************************
 474
 475 \begin{code}
 476 pprInstr :: Instr -> Doc
 477
 478 --pprInstr (COMMENT s) = empty -- nuke 'em
 479 pprInstr (COMMENT s)
 480    =  IF_ARCH_alpha( ((<>) (ptext SLIT("\t# ")) (ftext s))
 481      ,IF_ARCH_sparc( ((<>) (ptext SLIT("! "))   (ftext s))
 482      ,IF_ARCH_i386( ((<>) (ptext SLIT("# "))   (ftext s))
 483      ,IF_ARCH_powerpc( ((<>) (ptext SLIT("; ")) (ftext s))
 484      ,))))
 485
 486 pprInstr (DELTA d)
 487    = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
 488
 489 pprInstr (SEGMENT TextSegment)
 490     =  IF_ARCH_alpha(ptext SLIT("\t.text\n\t.align 3") {-word boundary-}
 491       ,IF_ARCH_sparc(ptext SLIT(".text\n\t.align 4") {-word boundary-}
 492       ,IF_ARCH_i386((text ".text\n\t.align 4,0x90") {-needs per-OS variation!-}
 493       ,IF_ARCH_powerpc(ptext SLIT(".text\n.align 2")
 494       ,))))
 495
 496 pprInstr (SEGMENT DataSegment)
 497     = ptext
 498          IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
 499         ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
 500         ,IF_ARCH_i386(SLIT(".data\n\t.align 4")
 501         ,IF_ARCH_powerpc(SLIT(".data\n.align 2")
 502         ,))))
 503
 504 pprInstr (SEGMENT RoDataSegment)
 505     = ptext
 506          IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
 507         ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
 508         ,IF_ARCH_i386(SLIT(".section .rodata\n\t.align 4")
 509         ,IF_ARCH_powerpc(SLIT(".const_data\n.align 2")
 510         ,))))
 511
 512 pprInstr (LABEL clab)
 513   = let
 514         pp_lab = pprCLabel_asm clab
 515     in
 516     hcat [
 517         if not (externallyVisibleCLabel clab) then
 518             empty
 519         else
 520             hcat [ptext
 521                          IF_ARCH_alpha(SLIT("\t.globl\t")
 522                         ,IF_ARCH_i386(SLIT(".globl ")
 523                         ,IF_ARCH_sparc(SLIT(".global\t")
 524                         ,IF_ARCH_powerpc(SLIT(".globl ")
 525                         ,))))
 526                         , pp_lab, char '\n'],
 527         pp_lab,
 528         char ':'
 529     ]
 530
 531 pprInstr (ASCII False{-no backslash conversion-} str)
 532   = hcat [ ptext SLIT("\t.asciz "), char '\"', text str, char '"' ]
 533
 534 pprInstr (ASCII True str)
 535   = vcat (map do1 (str ++ [chr 0]))
 536     where
 537        do1 :: Char -> Doc
 538        do1 c = ptext SLIT("\t.byte\t0x") <> hshow (ord c)
 539
 540        hshow :: Int -> Doc
 541        hshow n | n >= 0 && n <= 255
 542                = char (tab !! (n `div` 16)) <> char (tab !! (n `mod` 16))
 543        tab = "0123456789ABCDEF"
 544
 545
 546 pprInstr (DATA s xs)
 547   = vcat (concatMap (ppr_item s) xs)
 548     where
 549
 550 #if alpha_TARGET_ARCH
 551             ppr_item = error "ppr_item on Alpha"
 552 #endif
 553 #if sparc_TARGET_ARCH
 554         -- copy n paste of x86 version
 555         ppr_item B  x = [ptext SLIT("\t.byte\t") <> pprImm x]
 556         ppr_item W  x = [ptext SLIT("\t.long\t") <> pprImm x]
 557         ppr_item F  (ImmFloat r)
 558            = let bs = floatToBytes (fromRational r)
 559              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 560         ppr_item DF (ImmDouble r)
 561            = let bs = doubleToBytes (fromRational r)
 562              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 563 #endif
 564 #if i386_TARGET_ARCH
 565         ppr_item B  x = [ptext SLIT("\t.byte\t") <> pprImm x]
 566         ppr_item L  x = [ptext SLIT("\t.long\t") <> pprImm x]
 567         ppr_item F  (ImmFloat r)
 568            = let bs = floatToBytes (fromRational r)
 569              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 570         ppr_item DF (ImmDouble r)
 571            = let bs = doubleToBytes (fromRational r)
 572              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 573 #endif
 574 #if powerpc_TARGET_ARCH
 575         ppr_item B  x = [ptext SLIT("\t.byte\t") <> pprImm x]
 576         ppr_item Bu  x = [ptext SLIT("\t.byte\t") <> pprImm x]
 577         ppr_item H  x = [ptext SLIT("\t.byte\t") <> pprImm x]
 578         ppr_item Hu  x = [ptext SLIT("\t.byte\t") <> pprImm x]
 579         ppr_item W  x = [ptext SLIT("\t.long\t") <> pprImm x]
 580         ppr_item F  (ImmFloat r)
 581            = let bs = floatToBytes (fromRational r)
 582              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 583         ppr_item DF (ImmDouble r)
 584            = let bs = doubleToBytes (fromRational r)
 585              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 586 #endif
 587
 588 -- fall through to rest of (machine-specific) pprInstr...
 589 \end{code}
 590
 591 %************************************************************************
 592 %*                                                                      *
 593 \subsubsection{@pprInstr@ for an Alpha}
 594 %*                                                                      *
 595 %************************************************************************
 596
 597 \begin{code}
 598 #if alpha_TARGET_ARCH
 599
 600 pprInstr (LD size reg addr)
 601   = hcat [
 602         ptext SLIT("\tld"),
 603         pprSize size,
 604         char '\t',
 605         pprReg reg,
 606         comma,
 607         pprAddr addr
 608     ]
 609
 610 pprInstr (LDA reg addr)
 611   = hcat [
 612         ptext SLIT("\tlda\t"),
 613         pprReg reg,
 614         comma,
 615         pprAddr addr
 616     ]
 617
 618 pprInstr (LDAH reg addr)
 619   = hcat [
 620         ptext SLIT("\tldah\t"),
 621         pprReg reg,
 622         comma,
 623         pprAddr addr
 624     ]
 625
 626 pprInstr (LDGP reg addr)
 627   = hcat [
 628         ptext SLIT("\tldgp\t"),
 629         pprReg reg,
 630         comma,
 631         pprAddr addr
 632     ]
 633
 634 pprInstr (LDI size reg imm)
 635   = hcat [
 636         ptext SLIT("\tldi"),
 637         pprSize size,
 638         char '\t',
 639         pprReg reg,
 640         comma,
 641         pprImm imm
 642     ]
 643
 644 pprInstr (ST size reg addr)
 645   = hcat [
 646         ptext SLIT("\tst"),
 647         pprSize size,
 648         char '\t',
 649         pprReg reg,
 650         comma,
 651         pprAddr addr
 652     ]
 653
 654 pprInstr (CLR reg)
 655   = hcat [
 656         ptext SLIT("\tclr\t"),
 657         pprReg reg
 658     ]
 659
 660 pprInstr (ABS size ri reg)
 661   = hcat [
 662         ptext SLIT("\tabs"),
 663         pprSize size,
 664         char '\t',
 665         pprRI ri,
 666         comma,
 667         pprReg reg
 668     ]
 669
 670 pprInstr (NEG size ov ri reg)
 671   = hcat [
 672         ptext SLIT("\tneg"),
 673         pprSize size,
 674         if ov then ptext SLIT("v\t") else char '\t',
 675         pprRI ri,
 676         comma,
 677         pprReg reg
 678     ]
 679
 680 pprInstr (ADD size ov reg1 ri reg2)
 681   = hcat [
 682         ptext SLIT("\tadd"),
 683         pprSize size,
 684         if ov then ptext SLIT("v\t") else char '\t',
 685         pprReg reg1,
 686         comma,
 687         pprRI ri,
 688         comma,
 689         pprReg reg2
 690     ]
 691
 692 pprInstr (SADD size scale reg1 ri reg2)
 693   = hcat [
 694         ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
 695         ptext SLIT("add"),
 696         pprSize size,
 697         char '\t',
 698         pprReg reg1,
 699         comma,
 700         pprRI ri,
 701         comma,
 702         pprReg reg2
 703     ]
 704
 705 pprInstr (SUB size ov reg1 ri reg2)
 706   = hcat [
 707         ptext SLIT("\tsub"),
 708         pprSize size,
 709         if ov then ptext SLIT("v\t") else char '\t',
 710         pprReg reg1,
 711         comma,
 712         pprRI ri,
 713         comma,
 714         pprReg reg2
 715     ]
 716
 717 pprInstr (SSUB size scale reg1 ri reg2)
 718   = hcat [
 719         ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
 720         ptext SLIT("sub"),
 721         pprSize size,
 722         char '\t',
 723         pprReg reg1,
 724         comma,
 725         pprRI ri,
 726         comma,
 727         pprReg reg2
 728     ]
 729
 730 pprInstr (MUL size ov reg1 ri reg2)
 731   = hcat [
 732         ptext SLIT("\tmul"),
 733         pprSize size,
 734         if ov then ptext SLIT("v\t") else char '\t',
 735         pprReg reg1,
 736         comma,
 737         pprRI ri,
 738         comma,
 739         pprReg reg2
 740     ]
 741
 742 pprInstr (DIV size uns reg1 ri reg2)
 743   = hcat [
 744         ptext SLIT("\tdiv"),
 745         pprSize size,
 746         if uns then ptext SLIT("u\t") else char '\t',
 747         pprReg reg1,
 748         comma,
 749         pprRI ri,
 750         comma,
 751         pprReg reg2
 752     ]
 753
 754 pprInstr (REM size uns reg1 ri reg2)
 755   = hcat [
 756         ptext SLIT("\trem"),
 757         pprSize size,
 758         if uns then ptext SLIT("u\t") else char '\t',
 759         pprReg reg1,
 760         comma,
 761         pprRI ri,
 762         comma,
 763         pprReg reg2
 764     ]
 765
 766 pprInstr (NOT ri reg)
 767   = hcat [
 768         ptext SLIT("\tnot"),
 769         char '\t',
 770         pprRI ri,
 771         comma,
 772         pprReg reg
 773     ]
 774
 775 pprInstr (AND reg1 ri reg2) = pprRegRIReg SLIT("and") reg1 ri reg2
 776 pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg SLIT("andnot") reg1 ri reg2
 777 pprInstr (OR reg1 ri reg2) = pprRegRIReg SLIT("or") reg1 ri reg2
 778 pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg SLIT("ornot") reg1 ri reg2
 779 pprInstr (XOR reg1 ri reg2) = pprRegRIReg SLIT("xor") reg1 ri reg2
 780 pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg SLIT("xornot") reg1 ri reg2
 781
 782 pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") reg1 ri reg2
 783 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") reg1 ri reg2
 784 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") reg1 ri reg2
 785
 786 pprInstr (ZAP reg1 ri reg2) = pprRegRIReg SLIT("zap") reg1 ri reg2
 787 pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg SLIT("zapnot") reg1 ri reg2
 788
 789 pprInstr (NOP) = ptext SLIT("\tnop")
 790
 791 pprInstr (CMP cond reg1 ri reg2)
 792   = hcat [
 793         ptext SLIT("\tcmp"),
 794         pprCond cond,
 795         char '\t',
 796         pprReg reg1,
 797         comma,
 798         pprRI ri,
 799         comma,
 800         pprReg reg2
 801     ]
 802
 803 pprInstr (FCLR reg)
 804   = hcat [
 805         ptext SLIT("\tfclr\t"),
 806         pprReg reg
 807     ]
 808
 809 pprInstr (FABS reg1 reg2)
 810   = hcat [
 811         ptext SLIT("\tfabs\t"),
 812         pprReg reg1,
 813         comma,
 814         pprReg reg2
 815     ]
 816
 817 pprInstr (FNEG size reg1 reg2)
 818   = hcat [
 819         ptext SLIT("\tneg"),
 820         pprSize size,
 821         char '\t',
 822         pprReg reg1,
 823         comma,
 824         pprReg reg2
 825     ]
 826
 827 pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("add") size reg1 reg2 reg3
 828 pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("div") size reg1 reg2 reg3
 829 pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("mul") size reg1 reg2 reg3
 830 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("sub") size reg1 reg2 reg3
 831
 832 pprInstr (CVTxy size1 size2 reg1 reg2)
 833   = hcat [
 834         ptext SLIT("\tcvt"),
 835         pprSize size1,
 836         case size2 of {Q -> ptext SLIT("qc"); _ -> pprSize size2},
 837         char '\t',
 838         pprReg reg1,
 839         comma,
 840         pprReg reg2
 841     ]
 842
 843 pprInstr (FCMP size cond reg1 reg2 reg3)
 844   = hcat [
 845         ptext SLIT("\tcmp"),
 846         pprSize size,
 847         pprCond cond,
 848         char '\t',
 849         pprReg reg1,
 850         comma,
 851         pprReg reg2,
 852         comma,
 853         pprReg reg3
 854     ]
 855
 856 pprInstr (FMOV reg1 reg2)
 857   = hcat [
 858         ptext SLIT("\tfmov\t"),
 859         pprReg reg1,
 860         comma,
 861         pprReg reg2
 862     ]
 863
 864 pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
 865
 866 pprInstr (BI NEVER reg lab) = empty
 867
 868 pprInstr (BI cond reg lab)
 869   = hcat [
 870         ptext SLIT("\tb"),
 871         pprCond cond,
 872         char '\t',
 873         pprReg reg,
 874         comma,
 875         pprImm lab
 876     ]
 877
 878 pprInstr (BF cond reg lab)
 879   = hcat [
 880         ptext SLIT("\tfb"),
 881         pprCond cond,
 882         char '\t',
 883         pprReg reg,
 884         comma,
 885         pprImm lab
 886     ]
 887
 888 pprInstr (BR lab)
 889   = (<>) (ptext SLIT("\tbr\t")) (pprImm lab)
 890
 891 pprInstr (JMP reg addr hint)
 892   = hcat [
 893         ptext SLIT("\tjmp\t"),
 894         pprReg reg,
 895         comma,
 896         pprAddr addr,
 897         comma,
 898         int hint
 899     ]
 900
 901 pprInstr (BSR imm n)
 902   = (<>) (ptext SLIT("\tbsr\t")) (pprImm imm)
 903
 904 pprInstr (JSR reg addr n)
 905   = hcat [
 906         ptext SLIT("\tjsr\t"),
 907         pprReg reg,
 908         comma,
 909         pprAddr addr
 910     ]
 911
 912 pprInstr (FUNBEGIN clab)
 913   = hcat [
 914         if (externallyVisibleCLabel clab) then
 915             hcat [ptext SLIT("\t.globl\t"), pp_lab, char '\n']
 916         else
 917             empty,
 918         ptext SLIT("\t.ent "),
 919         pp_lab,
 920         char '\n',
 921         pp_lab,
 922         pp_ldgp,
 923         pp_lab,
 924         pp_frame
 925     ]
 926     where
 927         pp_lab = pprCLabel_asm clab
 928
 929         -- NEVER use commas within those string literals, cpp will ruin your day
 930         pp_ldgp  = hcat [ ptext SLIT(":\n\tldgp $29"), char ',', ptext SLIT("0($27)\n") ]
 931         pp_frame = hcat [ ptext SLIT("..ng:\n\t.frame $30"), char ',',
 932                           ptext SLIT("4240"), char ',',
 933                           ptext SLIT("$26"), char ',',
 934                           ptext SLIT("0\n\t.prologue 1") ]
 935
 936 pprInstr (FUNEND clab)
 937   = (<>) (ptext SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab)
 938 \end{code}
 939
 940 Continue with Alpha-only printing bits and bobs:
 941 \begin{code}
 942 pprRI :: RI -> Doc
 943
 944 pprRI (RIReg r) = pprReg r
 945 pprRI (RIImm r) = pprImm r
 946
 947 pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
 948 pprRegRIReg name reg1 ri reg2
 949   = hcat [
 950         char '\t',
 951         ptext name,
 952         char '\t',
 953         pprReg reg1,
 954         comma,
 955         pprRI ri,
 956         comma,
 957         pprReg reg2
 958     ]
 959
 960 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
 961 pprSizeRegRegReg name size reg1 reg2 reg3
 962   = hcat [
 963         char '\t',
 964         ptext name,
 965         pprSize size,
 966         char '\t',
 967         pprReg reg1,
 968         comma,
 969         pprReg reg2,
 970         comma,
 971         pprReg reg3
 972     ]
 973
 974 #endif {-alpha_TARGET_ARCH-}
 975 \end{code}
 976
 977 %************************************************************************
 978 %*                                                                      *
 979 \subsubsection{@pprInstr@ for an I386}
 980 %*                                                                      *
 981 %************************************************************************
 982
 983 \begin{code}
 984 #if i386_TARGET_ARCH
 985
 986 pprInstr v@(MOV size s@(OpReg src) d@(OpReg dst)) -- hack
 987   | src == dst
 988   =
 989 #if 0 /* #ifdef DEBUG */
 990     (<>) (ptext SLIT("# warning: ")) (pprSizeOpOp SLIT("mov") size s d)
 991 #else
 992     empty
 993 #endif
 994 pprInstr (MOV size src dst)
 995   = pprSizeOpOp SLIT("mov") size src dst
 996 pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce SLIT("movz") sizes L src dst
 997 pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce SLIT("movs") sizes L src dst
 998
 999 -- here we do some patching, since the physical registers are only set late
1000 -- in the code generation.
1001 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
1002   | reg1 == reg3
1003   = pprSizeOpOp SLIT("add") size (OpReg reg2) dst
1004 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
1005   | reg2 == reg3
1006   = pprSizeOpOp SLIT("add") size (OpReg reg1) dst
1007 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(Just reg1) Nothing displ)) dst@(OpReg reg3))
1008   | reg1 == reg3
1009   = pprInstr (ADD size (OpImm displ) dst)
1010 pprInstr (LEA size src dst) = pprSizeOpOp SLIT("lea") size src dst
1011
1012 pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
1013   = pprSizeOp SLIT("dec") size dst
1014 pprInstr (ADD size (OpImm (ImmInt 1)) dst)
1015   = pprSizeOp SLIT("inc") size dst
1016 pprInstr (ADD size src dst)
1017   = pprSizeOpOp SLIT("add") size src dst
1018 pprInstr (SUB size src dst) = pprSizeOpOp SLIT("sub") size src dst
1019 pprInstr (IMUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2
1020
1021 {- A hack.  The Intel documentation says that "The two and three
1022    operand forms [of IMUL] may also be used with unsigned operands
1023    because the lower half of the product is the same regardless if
1024    (sic) the operands are signed or unsigned.  The CF and OF flags,
1025    however, cannot be used to determine if the upper half of the
1026    result is non-zero."  So there.
1027 -}
1028 pprInstr (MUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2
1029
1030 pprInstr (AND size src dst) = pprSizeOpOp SLIT("and") size src dst
1031 pprInstr (OR  size src dst) = pprSizeOpOp SLIT("or")  size src dst
1032 pprInstr (XOR size src dst) = pprSizeOpOp SLIT("xor")  size src dst
1033 pprInstr (NOT size op) = pprSizeOp SLIT("not") size op
1034 pprInstr (NEGI size op) = pprSizeOp SLIT("neg") size op
1035
1036 pprInstr (SHL size imm dst) = pprSizeImmOp SLIT("shl") size imm dst
1037 pprInstr (SAR size imm dst) = pprSizeImmOp SLIT("sar") size imm dst
1038 pprInstr (SHR size imm dst) = pprSizeImmOp SLIT("shr") size imm dst
1039 pprInstr (BT  size imm src) = pprSizeImmOp SLIT("bt")  size imm src
1040
1041 pprInstr (CMP size src dst) = pprSizeOpOp SLIT("cmp")  size src dst
1042 pprInstr (TEST size src dst) = pprSizeOpOp SLIT("test")  size src dst
1043 pprInstr (PUSH size op) = pprSizeOp SLIT("push") size op
1044 pprInstr (POP size op) = pprSizeOp SLIT("pop") size op
1045 pprInstr PUSHA = ptext SLIT("\tpushal")
1046 pprInstr POPA = ptext SLIT("\tpopal")
1047
1048 pprInstr NOP = ptext SLIT("\tnop")
1049 pprInstr CLTD = ptext SLIT("\tcltd")
1050
1051 pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand B op)
1052
1053 pprInstr (JXX cond lab) = pprCondInstr SLIT("j") cond (pprCLabel_asm lab)
1054
1055 pprInstr (JMP dsts (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
1056 pprInstr (JMP dsts op)          = (<>) (ptext SLIT("\tjmp *")) (pprOperand L op)
1057 pprInstr (CALL (Left imm))      = (<>) (ptext SLIT("\tcall ")) (pprImm imm)
1058 pprInstr (CALL (Right reg))     = (<>) (ptext SLIT("\tcall *")) (pprReg L reg)
1059
1060 -- First bool indicates signedness; second whether quot or rem
1061 pprInstr (IQUOT sz src dst) = pprInstr_quotRem True True sz src dst
1062 pprInstr (IREM  sz src dst) = pprInstr_quotRem True False sz src dst
1063
1064 pprInstr (QUOT sz src dst) = pprInstr_quotRem False True sz src dst
1065 pprInstr (REM  sz src dst) = pprInstr_quotRem False False sz src dst
1066
1067 pprInstr (IMUL64 sd_hi sd_lo) = pprInstr_imul64 sd_hi sd_lo
1068
1069
1070 -- Simulating a flat register set on the x86 FP stack is tricky.
1071 -- you have to free %st(7) before pushing anything on the FP reg stack
1072 -- so as to preclude the possibility of a FP stack overflow exception.
1073 pprInstr g@(GMOV src dst)
1074    | src == dst
1075    = empty
1076    | otherwise
1077    = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
1078
1079 -- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FSTP (dst+1)
1080 pprInstr g@(GLD sz addr dst)
1081  = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp,
1082                  pprAddr addr, gsemi, gpop dst 1])
1083
1084 -- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
1085 pprInstr g@(GST sz src addr)
1086  = pprG g (hcat [gtab, gpush src 0, gsemi,
1087                  text "fstp", pprSize sz, gsp, pprAddr addr])
1088
1089 pprInstr g@(GLDZ dst)
1090  = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1])
1091 pprInstr g@(GLD1 dst)
1092  = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1])
1093
1094 pprInstr g@(GFTOI src dst)
1095    = pprInstr (GDTOI src dst)
1096 pprInstr g@(GDTOI src dst)
1097    = pprG g (hcat [gtab, text "subl $4, %esp ; ",
1098                    gpush src 0, gsemi, text "fistpl 0(%esp) ; popl ",
1099                    pprReg L dst])
1100
1101 pprInstr g@(GITOF src dst)
1102    = pprInstr (GITOD src dst)
1103 pprInstr g@(GITOD src dst)
1104    = pprG g (hcat [gtab, text "pushl ", pprReg L src,
1105                    text " ; ffree %st(7); fildl (%esp) ; ",
1106                    gpop dst 1, text " ; addl $4,%esp"])
1107
1108 {- Gruesome swamp follows.  If you're unfortunate enough to have ventured
1109    this far into the jungle AND you give a Rat's Ass (tm) what's going
1110    on, here's the deal.  Generate code to do a floating point comparison
1111    of src1 and src2, of kind cond, and set the Zero flag if true.
1112
1113    The complications are to do with handling NaNs correctly.  We want the
1114    property that if either argument is NaN, then the result of the
1115    comparison is False ... except if we're comparing for inequality,
1116    in which case the answer is True.
1117
1118    Here's how the general (non-inequality) case works.  As an
1119    example, consider generating the an equality test:
1120
1121      pushl %eax         -- we need to mess with this
1122      <get src1 to top of FPU stack>
1123      fcomp <src2 location in FPU stack> and pop pushed src1
1124                 -- Result of comparison is in FPU Status Register bits
1125                 -- C3 C2 and C0
1126      fstsw %ax  -- Move FPU Status Reg to %ax
1127      sahf       -- move C3 C2 C0 from %ax to integer flag reg
1128      -- now the serious magic begins
1129      setpo %ah     -- %ah = if comparable(neither arg was NaN) then 1 else 0
1130      sete  %al     -- %al = if arg1 == arg2 then 1 else 0
1131      andb %ah,%al  -- %al &= %ah
1132                    -- so %al == 1 iff (comparable && same); else it holds 0
1133      decb %al      -- %al == 0, ZeroFlag=1  iff (comparable && same);
1134                       else %al == 0xFF, ZeroFlag=0
1135      -- the zero flag is now set as we desire.
1136      popl %eax
1137
1138    The special case of inequality differs thusly:
1139
1140      setpe %ah     -- %ah = if incomparable(either arg was NaN) then 1 else 0
1141      setne %al     -- %al = if arg1 /= arg2 then 1 else 0
1142      orb %ah,%al   -- %al = if (incomparable || different) then 1 else 0
1143      decb %al      -- if (incomparable || different) then (%al == 0, ZF=1)
1144                                                      else (%al == 0xFF, ZF=0)
1145 -}
1146 pprInstr g@(GCMP cond src1 src2)
1147    | case cond of { NE -> True; other -> False }
1148    = pprG g (vcat [
1149         hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1150         hcat [gtab, text "fcomp ", greg src2 1,
1151                     text "; fstsw %ax ; sahf ;  setpe %ah"],
1152         hcat [gtab, text "setne %al ;  ",
1153               text "orb %ah,%al ;  decb %al ;  popl %eax"]
1154     ])
1155    | otherwise
1156    = pprG g (vcat [
1157         hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1158         hcat [gtab, text "fcomp ", greg src2 1,
1159                     text "; fstsw %ax ; sahf ;  setpo %ah"],
1160         hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ;  ",
1161               text "andb %ah,%al ;  decb %al ;  popl %eax"]
1162     ])
1163     where
1164         {- On the 486, the flags set by FP compare are the unsigned ones!
1165            (This looks like a HACK to me.  WDP 96/03)
1166         -}
1167         fix_FP_cond :: Cond -> Cond
1168         fix_FP_cond GE   = GEU
1169         fix_FP_cond GTT  = GU
1170         fix_FP_cond LTT  = LU
1171         fix_FP_cond LE   = LEU
1172         fix_FP_cond EQQ  = EQQ
1173         fix_FP_cond NE   = NE
1174         -- there should be no others
1175
1176
1177 pprInstr g@(GABS sz src dst)
1178    = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
1179 pprInstr g@(GNEG sz src dst)
1180    = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
1181
1182 pprInstr g@(GSQRT sz src dst)
1183    = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
1184              hcat [gtab, gcoerceto sz, gpop dst 1])
1185 pprInstr g@(GSIN sz src dst)
1186    = pprG g (hcat [gtab, gpush src 0, text " ; fsin"] $$
1187              hcat [gtab, gcoerceto sz, gpop dst 1])
1188 pprInstr g@(GCOS sz src dst)
1189    = pprG g (hcat [gtab, gpush src 0, text " ; fcos"] $$
1190              hcat [gtab, gcoerceto sz, gpop dst 1])
1191 pprInstr g@(GTAN sz src dst)
1192    = pprG g (hcat [gtab, text "ffree %st(6) ; ",
1193                    gpush src 0, text " ; fptan ; ",
1194                    text " fstp %st(0)"] $$
1195              hcat [gtab, gcoerceto sz, gpop dst 1])
1196
1197 -- In the translations for GADD, GMUL, GSUB and GDIV,
1198 -- the first two cases are mere optimisations.  The otherwise clause
1199 -- generates correct code under all circumstances.
1200
1201 pprInstr g@(GADD sz src1 src2 dst)
1202    | src1 == dst
1203    = pprG g (text "\t#GADD-xxxcase1" $$
1204              hcat [gtab, gpush src2 0,
1205                    text " ; faddp %st(0),", greg src1 1])
1206    | src2 == dst
1207    = pprG g (text "\t#GADD-xxxcase2" $$
1208              hcat [gtab, gpush src1 0,
1209                    text " ; faddp %st(0),", greg src2 1])
1210    | otherwise
1211    = pprG g (hcat [gtab, gpush src1 0,
1212                    text " ; fadd ", greg src2 1, text ",%st(0)",
1213                    gsemi, gpop dst 1])
1214
1215
1216 pprInstr g@(GMUL sz src1 src2 dst)
1217    | src1 == dst
1218    = pprG g (text "\t#GMUL-xxxcase1" $$
1219              hcat [gtab, gpush src2 0,
1220                    text " ; fmulp %st(0),", greg src1 1])
1221    | src2 == dst
1222    = pprG g (text "\t#GMUL-xxxcase2" $$
1223              hcat [gtab, gpush src1 0,
1224                    text " ; fmulp %st(0),", greg src2 1])
1225    | otherwise
1226    = pprG g (hcat [gtab, gpush src1 0,
1227                    text " ; fmul ", greg src2 1, text ",%st(0)",
1228                    gsemi, gpop dst 1])
1229
1230
1231 pprInstr g@(GSUB sz src1 src2 dst)
1232    | src1 == dst
1233    = pprG g (text "\t#GSUB-xxxcase1" $$
1234              hcat [gtab, gpush src2 0,
1235                    text " ; fsubrp %st(0),", greg src1 1])
1236    | src2 == dst
1237    = pprG g (text "\t#GSUB-xxxcase2" $$
1238              hcat [gtab, gpush src1 0,
1239                    text " ; fsubp %st(0),", greg src2 1])
1240    | otherwise
1241    = pprG g (hcat [gtab, gpush src1 0,
1242                    text " ; fsub ", greg src2 1, text ",%st(0)",
1243                    gsemi, gpop dst 1])
1244
1245
1246 pprInstr g@(GDIV sz src1 src2 dst)
1247    | src1 == dst
1248    = pprG g (text "\t#GDIV-xxxcase1" $$
1249              hcat [gtab, gpush src2 0,
1250                    text " ; fdivrp %st(0),", greg src1 1])
1251    | src2 == dst
1252    = pprG g (text "\t#GDIV-xxxcase2" $$
1253              hcat [gtab, gpush src1 0,
1254                    text " ; fdivp %st(0),", greg src2 1])
1255    | otherwise
1256    = pprG g (hcat [gtab, gpush src1 0,
1257                    text " ; fdiv ", greg src2 1, text ",%st(0)",
1258                    gsemi, gpop dst 1])
1259
1260
1261 pprInstr GFREE
1262    = vcat [ ptext SLIT("\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
1263             ptext SLIT("\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)")
1264           ]
1265
1266
1267 pprInstr_quotRem signed isQuot sz src dst
1268    | case sz of L -> False; _ -> True
1269    = panic "pprInstr_quotRem: dunno how to do non-32bit operands"
1270    | otherwise
1271    = vcat [
1272      (text "\t# BEGIN " <> fakeInsn),
1273      (text "\tpushl $0;  pushl %eax;  pushl %edx;  pushl " <> pprOperand sz src),
1274      (text "\tmovl " <> pprOperand sz dst <> text ",%eax;  " <> widen_to_64),
1275      (x86op <> text " 0(%esp);  movl " <> text resReg <> text ",12(%esp)"),
1276      (text "\tpopl %edx;  popl %edx;  popl %eax;  popl " <> pprOperand sz dst),
1277      (text "\t# END   " <> fakeInsn)
1278      ]
1279      where
1280         widen_to_64 | signed     = text "cltd"
1281                     | not signed = text "xorl %edx,%edx"
1282         x86op = if signed then text "\tidivl" else text "\tdivl"
1283         resReg = if isQuot then "%eax" else "%edx"
1284         opStr  | signed     = if isQuot then "IQUOT" else "IREM"
1285                | not signed = if isQuot then "QUOT"  else "REM"
1286         fakeInsn = text opStr <+> pprOperand sz src
1287                               <> char ',' <+> pprOperand sz dst
1288
1289 -- Emit code to make hi_reg:lo_reg be the 64-bit product of hi_reg and lo_reg
1290 pprInstr_imul64 hi_reg lo_reg
1291    = let fakeInsn = text "imul64" <+> pp_hi_reg <> comma <+> pp_lo_reg
1292          pp_hi_reg = pprReg L hi_reg
1293          pp_lo_reg = pprReg L lo_reg
1294      in
1295          vcat [
1296             text "\t# BEGIN " <> fakeInsn,
1297             text "\tpushl" <+> pp_hi_reg <> text" ;  pushl" <+> pp_lo_reg,
1298             text "\tpushl %eax ; pushl %edx",
1299             text "\tmovl 12(%esp), %eax ; imull 8(%esp)",
1300             text "\tmovl %edx, 12(%esp) ; movl %eax, 8(%esp)",
1301             text "\tpopl %edx ; popl %eax",
1302             text "\tpopl" <+> pp_lo_reg <> text " ;  popl" <+> pp_hi_reg,
1303             text "\t# END   " <> fakeInsn
1304          ]
1305
1306
1307 --------------------------
1308
1309 -- coerce %st(0) to the specified size
1310 gcoerceto DF = empty
1311 gcoerceto  F = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
1312
1313 gpush reg offset
1314    = hcat [text "ffree %st(7) ; fld ", greg reg offset]
1315 gpop reg offset
1316    = hcat [text "fstp ", greg reg offset]
1317
1318 bogus = text "\tbogus"
1319 greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
1320 gsemi = text " ; "
1321 gtab  = char '\t'
1322 gsp   = char ' '
1323
1324 gregno (RealReg i) = i
1325 gregno other       = --pprPanic "gregno" (ppr other)
1326                      999   -- bogus; only needed for debug printing
1327
1328 pprG :: Instr -> Doc -> Doc
1329 pprG fake actual
1330    = (char '#' <> pprGInstr fake) $$ actual
1331
1332 pprGInstr (GMOV src dst)   = pprSizeRegReg SLIT("gmov") DF src dst
1333 pprGInstr (GLD sz src dst) = pprSizeAddrReg SLIT("gld") sz src dst
1334 pprGInstr (GST sz src dst) = pprSizeRegAddr SLIT("gst") sz src dst
1335
1336 pprGInstr (GLDZ dst) = pprSizeReg SLIT("gldz") DF dst
1337 pprGInstr (GLD1 dst) = pprSizeReg SLIT("gld1") DF dst
1338
1339 pprGInstr (GFTOI src dst) = pprSizeSizeRegReg SLIT("gftoi") F L  src dst
1340 pprGInstr (GDTOI src dst) = pprSizeSizeRegReg SLIT("gdtoi") DF L src dst
1341
1342 pprGInstr (GITOF src dst) = pprSizeSizeRegReg SLIT("gitof") L F  src dst
1343 pprGInstr (GITOD src dst) = pprSizeSizeRegReg SLIT("gitod") L DF src dst
1344
1345 pprGInstr (GCMP co src dst) = pprCondRegReg SLIT("gcmp_") DF co src dst
1346 pprGInstr (GABS sz src dst) = pprSizeRegReg SLIT("gabs") sz src dst
1347 pprGInstr (GNEG sz src dst) = pprSizeRegReg SLIT("gneg") sz src dst
1348 pprGInstr (GSQRT sz src dst) = pprSizeRegReg SLIT("gsqrt") sz src dst
1349 pprGInstr (GSIN sz src dst) = pprSizeRegReg SLIT("gsin") sz src dst
1350 pprGInstr (GCOS sz src dst) = pprSizeRegReg SLIT("gcos") sz src dst
1351 pprGInstr (GTAN sz src dst) = pprSizeRegReg SLIT("gtan") sz src dst
1352
1353 pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg SLIT("gadd") sz src1 src2 dst
1354 pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg SLIT("gsub") sz src1 src2 dst
1355 pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg SLIT("gmul") sz src1 src2 dst
1356 pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg SLIT("gdiv") sz src1 src2 dst
1357 \end{code}
1358
1359 Continue with I386-only printing bits and bobs:
1360 \begin{code}
1361 pprDollImm :: Imm -> Doc
1362
1363 pprDollImm i =  ptext SLIT("$") <> pprImm i
1364
1365 pprOperand :: Size -> Operand -> Doc
1366 pprOperand s (OpReg r)   = pprReg s r
1367 pprOperand s (OpImm i)   = pprDollImm i
1368 pprOperand s (OpAddr ea) = pprAddr ea
1369
1370 pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc
1371 pprSizeImmOp name size imm op1
1372   = hcat [
1373         char '\t',
1374         ptext name,
1375         pprSize size,
1376         space,
1377         char '$',
1378         pprImm imm,
1379         comma,
1380         pprOperand size op1
1381     ]
1382
1383 pprSizeOp :: LitString -> Size -> Operand -> Doc
1384 pprSizeOp name size op1
1385   = hcat [
1386         char '\t',
1387         ptext name,
1388         pprSize size,
1389         space,
1390         pprOperand size op1
1391     ]
1392
1393 pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1394 pprSizeOpOp name size op1 op2
1395   = hcat [
1396         char '\t',
1397         ptext name,
1398         pprSize size,
1399         space,
1400         pprOperand size op1,
1401         comma,
1402         pprOperand size op2
1403     ]
1404
1405 pprSizeByteOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1406 pprSizeByteOpOp name size op1 op2
1407   = hcat [
1408         char '\t',
1409         ptext name,
1410         pprSize size,
1411         space,
1412         pprOperand B op1,
1413         comma,
1414         pprOperand size op2
1415     ]
1416
1417 pprSizeOpReg :: LitString -> Size -> Operand -> Reg -> Doc
1418 pprSizeOpReg name size op1 reg
1419   = hcat [
1420         char '\t',
1421         ptext name,
1422         pprSize size,
1423         space,
1424         pprOperand size op1,
1425         comma,
1426         pprReg size reg
1427     ]
1428
1429 pprSizeReg :: LitString -> Size -> Reg -> Doc
1430 pprSizeReg name size reg1
1431   = hcat [
1432         char '\t',
1433         ptext name,
1434         pprSize size,
1435         space,
1436         pprReg size reg1
1437     ]
1438
1439 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
1440 pprSizeRegReg name size reg1 reg2
1441   = hcat [
1442         char '\t',
1443         ptext name,
1444         pprSize size,
1445         space,
1446         pprReg size reg1,
1447         comma,
1448         pprReg size reg2
1449     ]
1450
1451 pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc
1452 pprCondRegReg name size cond reg1 reg2
1453   = hcat [
1454         char '\t',
1455         ptext name,
1456         pprCond cond,
1457         space,
1458         pprReg size reg1,
1459         comma,
1460         pprReg size reg2
1461     ]
1462
1463 pprSizeSizeRegReg :: LitString -> Size -> Size -> Reg -> Reg -> Doc
1464 pprSizeSizeRegReg name size1 size2 reg1 reg2
1465   = hcat [
1466         char '\t',
1467         ptext name,
1468         pprSize size1,
1469         pprSize size2,
1470         space,
1471         pprReg size1 reg1,
1472
1473         comma,
1474         pprReg size2 reg2
1475     ]
1476
1477 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1478 pprSizeRegRegReg name size reg1 reg2 reg3
1479   = hcat [
1480         char '\t',
1481         ptext name,
1482         pprSize size,
1483         space,
1484         pprReg size reg1,
1485         comma,
1486         pprReg size reg2,
1487         comma,
1488         pprReg size reg3
1489     ]
1490
1491 pprSizeAddr :: LitString -> Size -> MachRegsAddr -> Doc
1492 pprSizeAddr name size op
1493   = hcat [
1494         char '\t',
1495         ptext name,
1496         pprSize size,
1497         space,
1498         pprAddr op
1499     ]
1500
1501 pprSizeAddrReg :: LitString -> Size -> MachRegsAddr -> Reg -> Doc
1502 pprSizeAddrReg name size op dst
1503   = hcat [
1504         char '\t',
1505         ptext name,
1506         pprSize size,
1507         space,
1508         pprAddr op,
1509         comma,
1510         pprReg size dst
1511     ]
1512
1513 pprSizeRegAddr :: LitString -> Size -> Reg -> MachRegsAddr -> Doc
1514 pprSizeRegAddr name size src op
1515   = hcat [
1516         char '\t',
1517         ptext name,
1518         pprSize size,
1519         space,
1520         pprReg size src,
1521         comma,
1522         pprAddr op
1523     ]
1524
1525 pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1526 pprOpOp name size op1 op2
1527   = hcat [
1528         char '\t',
1529         ptext name, space,
1530         pprOperand size op1,
1531         comma,
1532         pprOperand size op2
1533     ]
1534
1535 pprSizeOpOpCoerce :: LitString -> Size -> Size -> Operand -> Operand -> Doc
1536 pprSizeOpOpCoerce name size1 size2 op1 op2
1537   = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
1538         pprOperand size1 op1,
1539         comma,
1540         pprOperand size2 op2
1541     ]
1542
1543 pprCondInstr :: LitString -> Cond -> Doc -> Doc
1544 pprCondInstr name cond arg
1545   = hcat [ char '\t', ptext name, pprCond cond, space, arg]
1546
1547 #endif {-i386_TARGET_ARCH-}
1548 \end{code}
1549
1550 %************************************************************************
1551 %*                                                                      *
1552 \subsubsection{@pprInstr@ for a SPARC}
1553 %*                                                                      *
1554 %************************************************************************
1555
1556 \begin{code}
1557 #if sparc_TARGET_ARCH
1558
1559 -- a clumsy hack for now, to handle possible double alignment problems
1560
1561 -- even clumsier, to allow for RegReg regs that show when doing indexed
1562 -- reads (bytearrays).
1563 --
1564
1565 -- Translate to the following:
1566 --    add g1,g2,g1
1567 --    ld  [g1],%fn
1568 --    ld  [g1+4],%f(n+1)
1569 --    sub g1,g2,g1           -- to restore g1
1570 pprInstr (LD DF (AddrRegReg g1 g2) reg)
1571   = vcat [
1572        hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1573        hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg],
1574        hcat [pp_ld_lbracket, pprReg g1, ptext SLIT("+4]"), comma, pprReg (fPair reg)],
1575        hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1576     ]
1577
1578 -- Translate to
1579 --    ld  [addr],%fn
1580 --    ld  [addr+4],%f(n+1)
1581 pprInstr (LD DF addr reg) | isJust off_addr
1582   = vcat [
1583        hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
1584        hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg (fPair reg)]
1585     ]
1586   where
1587     off_addr = addrOffset addr 4
1588     addr2 = case off_addr of Just x -> x
1589
1590
1591 pprInstr (LD size addr reg)
1592   = hcat [
1593        ptext SLIT("\tld"),
1594        pprSize size,
1595        char '\t',
1596        lbrack,
1597        pprAddr addr,
1598        pp_rbracket_comma,
1599        pprReg reg
1600     ]
1601
1602 -- The same clumsy hack as above
1603
1604 -- Translate to the following:
1605 --    add g1,g2,g1
1606 --    st  %fn,[g1]
1607 --    st  %f(n+1),[g1+4]
1608 --    sub g1,g2,g1           -- to restore g1
1609 pprInstr (ST DF reg (AddrRegReg g1 g2))
1610  = vcat [
1611        hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1612        hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1613              pprReg g1, rbrack],
1614        hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1615              pprReg g1, ptext SLIT("+4]")],
1616        hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1617     ]
1618
1619 -- Translate to
1620 --    st  %fn,[addr]
1621 --    st  %f(n+1),[addr+4]
1622 pprInstr (ST DF reg addr) | isJust off_addr
1623  = vcat [
1624       hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1625             pprAddr addr, rbrack],
1626       hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1627             pprAddr addr2, rbrack]
1628     ]
1629   where
1630     off_addr = addrOffset addr 4
1631     addr2 = case off_addr of Just x -> x
1632
1633 -- no distinction is made between signed and unsigned bytes on stores for the
1634 -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
1635 -- so we call a special-purpose pprSize for ST..
1636
1637 pprInstr (ST size reg addr)
1638   = hcat [
1639        ptext SLIT("\tst"),
1640        pprStSize size,
1641        char '\t',
1642        pprReg reg,
1643        pp_comma_lbracket,
1644        pprAddr addr,
1645        rbrack
1646     ]
1647
1648 pprInstr (ADD x cc reg1 ri reg2)
1649   | not x && not cc && riZero ri
1650   = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1651   | otherwise
1652   = pprRegRIReg (if x then SLIT("addx") else SLIT("add")) cc reg1 ri reg2
1653
1654 pprInstr (SUB x cc reg1 ri reg2)
1655   | not x && cc && reg2 == g0
1656   = hcat [ ptext SLIT("\tcmp\t"), pprReg reg1, comma, pprRI ri ]
1657   | not x && not cc && riZero ri
1658   = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1659   | otherwise
1660   = pprRegRIReg (if x then SLIT("subx") else SLIT("sub")) cc reg1 ri reg2
1661
1662 pprInstr (AND  b reg1 ri reg2) = pprRegRIReg SLIT("and")  b reg1 ri reg2
1663 pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg SLIT("andn") b reg1 ri reg2
1664
1665 pprInstr (OR b reg1 ri reg2)
1666   | not b && reg1 == g0
1667   = let doit = hcat [ ptext SLIT("\tmov\t"), pprRI ri, comma, pprReg reg2 ]
1668     in  case ri of
1669            RIReg rrr | rrr == reg2 -> empty
1670            other                   -> doit
1671   | otherwise
1672   = pprRegRIReg SLIT("or") b reg1 ri reg2
1673
1674 pprInstr (ORN b reg1 ri reg2) = pprRegRIReg SLIT("orn") b reg1 ri reg2
1675
1676 pprInstr (XOR  b reg1 ri reg2) = pprRegRIReg SLIT("xor")  b reg1 ri reg2
1677 pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg SLIT("xnor") b reg1 ri reg2
1678
1679 pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") False reg1 ri reg2
1680 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") False reg1 ri reg2
1681 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") False reg1 ri reg2
1682
1683 pprInstr (RDY rd) = ptext SLIT("\trd\t%y,") <> pprReg rd
1684 pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg SLIT("smul")  b reg1 ri reg2
1685 pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg SLIT("umul")  b reg1 ri reg2
1686
1687 pprInstr (SETHI imm reg)
1688   = hcat [
1689         ptext SLIT("\tsethi\t"),
1690         pprImm imm,
1691         comma,
1692         pprReg reg
1693     ]
1694
1695 pprInstr NOP = ptext SLIT("\tnop")
1696
1697 pprInstr (FABS F reg1 reg2) = pprSizeRegReg SLIT("fabs") F reg1 reg2
1698 pprInstr (FABS DF reg1 reg2)
1699   = (<>) (pprSizeRegReg SLIT("fabs") F reg1 reg2)
1700     (if (reg1 == reg2) then empty
1701      else (<>) (char '\n')
1702           (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
1703
1704 pprInstr (FADD size reg1 reg2 reg3)
1705   = pprSizeRegRegReg SLIT("fadd") size reg1 reg2 reg3
1706 pprInstr (FCMP e size reg1 reg2)
1707   = pprSizeRegReg (if e then SLIT("fcmpe") else SLIT("fcmp")) size reg1 reg2
1708 pprInstr (FDIV size reg1 reg2 reg3)
1709   = pprSizeRegRegReg SLIT("fdiv") size reg1 reg2 reg3
1710
1711 pprInstr (FMOV F reg1 reg2) = pprSizeRegReg SLIT("fmov") F reg1 reg2
1712 pprInstr (FMOV DF reg1 reg2)
1713   = (<>) (pprSizeRegReg SLIT("fmov") F reg1 reg2)
1714     (if (reg1 == reg2) then empty
1715      else (<>) (char '\n')
1716           (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
1717
1718 pprInstr (FMUL size reg1 reg2 reg3)
1719   = pprSizeRegRegReg SLIT("fmul") size reg1 reg2 reg3
1720
1721 pprInstr (FNEG F reg1 reg2) = pprSizeRegReg SLIT("fneg") F reg1 reg2
1722 pprInstr (FNEG DF reg1 reg2)
1723   = (<>) (pprSizeRegReg SLIT("fneg") F reg1 reg2)
1724     (if (reg1 == reg2) then empty
1725      else (<>) (char '\n')
1726           (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
1727
1728 pprInstr (FSQRT size reg1 reg2)     = pprSizeRegReg SLIT("fsqrt") size reg1 reg2
1729 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fsub") size reg1 reg2 reg3
1730 pprInstr (FxTOy size1 size2 reg1 reg2)
1731   = hcat [
1732         ptext SLIT("\tf"),
1733         ptext
1734         (case size1 of
1735             W  -> SLIT("ito")
1736             F  -> SLIT("sto")
1737             DF -> SLIT("dto")),
1738         ptext
1739         (case size2 of
1740             W  -> SLIT("i\t")
1741             F  -> SLIT("s\t")
1742             DF -> SLIT("d\t")),
1743         pprReg reg1, comma, pprReg reg2
1744     ]
1745
1746
1747 pprInstr (BI cond b lab)
1748   = hcat [
1749         ptext SLIT("\tb"), pprCond cond,
1750         if b then pp_comma_a else empty,
1751         char '\t',
1752         pprImm lab
1753     ]
1754
1755 pprInstr (BF cond b lab)
1756   = hcat [
1757         ptext SLIT("\tfb"), pprCond cond,
1758         if b then pp_comma_a else empty,
1759         char '\t',
1760         pprImm lab
1761     ]
1762
1763 pprInstr (JMP dsts addr) = (<>) (ptext SLIT("\tjmp\t")) (pprAddr addr)
1764
1765 pprInstr (CALL (Left imm) n _)
1766   = hcat [ ptext SLIT("\tcall\t"), pprImm imm, comma, int n ]
1767 pprInstr (CALL (Right reg) n _)
1768   = hcat [ ptext SLIT("\tcall\t"), pprReg reg, comma, int n ]
1769 \end{code}
1770
1771 Continue with SPARC-only printing bits and bobs:
1772 \begin{code}
1773 pprRI :: RI -> Doc
1774 pprRI (RIReg r) = pprReg r
1775 pprRI (RIImm r) = pprImm r
1776
1777 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
1778 pprSizeRegReg name size reg1 reg2
1779   = hcat [
1780         char '\t',
1781         ptext name,
1782         (case size of
1783             F  -> ptext SLIT("s\t")
1784             DF -> ptext SLIT("d\t")),
1785         pprReg reg1,
1786         comma,
1787         pprReg reg2
1788     ]
1789
1790 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1791 pprSizeRegRegReg name size reg1 reg2 reg3
1792   = hcat [
1793         char '\t',
1794         ptext name,
1795         (case size of
1796             F  -> ptext SLIT("s\t")
1797             DF -> ptext SLIT("d\t")),
1798         pprReg reg1,
1799         comma,
1800         pprReg reg2,
1801         comma,
1802         pprReg reg3
1803     ]
1804
1805 pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
1806 pprRegRIReg name b reg1 ri reg2
1807   = hcat [
1808         char '\t',
1809         ptext name,
1810         if b then ptext SLIT("cc\t") else char '\t',
1811         pprReg reg1,
1812         comma,
1813         pprRI ri,
1814         comma,
1815         pprReg reg2
1816     ]
1817
1818 pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
1819 pprRIReg name b ri reg1
1820   = hcat [
1821         char '\t',
1822         ptext name,
1823         if b then ptext SLIT("cc\t") else char '\t',
1824         pprRI ri,
1825         comma,
1826         pprReg reg1
1827     ]
1828
1829 pp_ld_lbracket    = ptext SLIT("\tld\t[")
1830 pp_rbracket_comma = text "],"
1831 pp_comma_lbracket = text ",["
1832 pp_comma_a        = text ",a"
1833
1834 #endif {-sparc_TARGET_ARCH-}
1835 \end{code}
1836
1837 %************************************************************************
1838 %*                                                                      *
1839 \subsubsection{@pprInstr@ for PowerPC}
1840 %*                                                                      *
1841 %************************************************************************
1842
1843 \begin{code}
1844 #if powerpc_TARGET_ARCH
1845 pprInstr (LD sz reg addr) = hcat [
1846         char '\t',
1847         ptext SLIT("l"),
1848         ptext (case sz of
1849             B   -> SLIT("ba")
1850             Bu  -> SLIT("bz")
1851             H   -> SLIT("ha")
1852             Hu  -> SLIT("hz")
1853             W   -> SLIT("wz")
1854             F   -> SLIT("fs")
1855             DF  -> SLIT("fd")),
1856         char '\t',
1857         pprReg reg,
1858         ptext SLIT(", "),
1859         pprAddr addr
1860     ]
1861 pprInstr (ST sz reg addr) = hcat [
1862         char '\t',
1863         ptext SLIT("st"),
1864         pprSize sz,
1865         char '\t',
1866         pprReg reg,
1867         ptext SLIT(", "),
1868         pprAddr addr
1869     ]
1870 pprInstr (STU sz reg addr) = hcat [
1871         char '\t',
1872         ptext SLIT("st"),
1873         pprSize sz,
1874         ptext SLIT("u\t"),
1875         pprReg reg,
1876         ptext SLIT(", "),
1877         pprAddr addr
1878     ]
1879 pprInstr (LIS reg imm) = hcat [
1880         char '\t',
1881         ptext SLIT("lis"),
1882         char '\t',
1883         pprReg reg,
1884         ptext SLIT(", "),
1885         pprImm imm
1886     ]
1887 pprInstr (LI reg imm) = hcat [
1888         char '\t',
1889         ptext SLIT("li"),
1890         char '\t',
1891         pprReg reg,
1892         ptext SLIT(", "),
1893         pprImm imm
1894     ]
1895 pprInstr (MR reg1 reg2) = hcat [
1896         char '\t',
1897         case regClass reg1 of
1898             RcInteger -> ptext SLIT("mr")
1899             _ -> ptext SLIT("fmr"),
1900         char '\t',
1901         pprReg reg1,
1902         ptext SLIT(", "),
1903         pprReg reg2
1904     ]
1905 pprInstr (CMP sz reg ri) = hcat [
1906         char '\t',
1907         op,
1908         char '\t',
1909         pprReg reg,
1910         ptext SLIT(", "),
1911         pprRI ri
1912     ]
1913     where
1914         op = hcat [
1915                 ptext SLIT("cmp"),
1916                 pprSize sz,
1917                 case ri of
1918                     RIReg _ -> empty
1919                     RIImm _ -> char 'i'
1920             ]
1921 pprInstr (CMPL sz reg ri) = hcat [
1922         char '\t',
1923         op,
1924         char '\t',
1925         pprReg reg,
1926         ptext SLIT(", "),
1927         pprRI ri
1928     ]
1929     where
1930         op = hcat [
1931                 ptext SLIT("cmpl"),
1932                 pprSize sz,
1933                 case ri of
1934                     RIReg _ -> empty
1935                     RIImm _ -> char 'i'
1936             ]
1937 pprInstr (BCC cond lbl) = hcat [
1938         char '\t',
1939         ptext SLIT("b"),
1940         pprCond cond,
1941         char '\t',
1942         pprCLabel_asm lbl
1943     ]
1944
1945 pprInstr (MTCTR reg) = hcat [
1946         char '\t',
1947         ptext SLIT("mtctr"),
1948         char '\t',
1949         pprReg reg
1950     ]
1951 pprInstr (BCTR) = hcat [
1952         char '\t',
1953         ptext SLIT("bctr")
1954     ]
1955 pprInstr (BL imm _) = hcat [
1956         char '\t',
1957         ptext SLIT("bl"),
1958         char '\t',
1959         pprImm imm
1960     ]
1961 pprInstr (BCTRL _) = hcat [
1962         char '\t',
1963         ptext SLIT("bctrl")
1964     ]
1965 pprInstr (ADD reg1 reg2 ri) = pprLogic SLIT("add") reg1 reg2 ri
1966 pprInstr (SUBF reg1 reg2 ri) = pprLogic SLIT("subf") reg1 reg2 ri
1967 pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic SLIT("mullw") reg1 reg2 ri
1968 pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic SLIT("mull") reg1 reg2 ri
1969 pprInstr (DIVW reg1 reg2 reg3) = pprLogic SLIT("divw") reg1 reg2 (RIReg reg3)
1970 pprInstr (DIVWU reg1 reg2 reg3) = pprLogic SLIT("divwu") reg1 reg2 (RIReg reg3)
1971 pprInstr (AND reg1 reg2 ri) = pprLogic SLIT("and") reg1 reg2 ri
1972 pprInstr (OR reg1 reg2 ri) = pprLogic SLIT("or") reg1 reg2 ri
1973 pprInstr (XOR reg1 reg2 ri) = pprLogic SLIT("xor") reg1 reg2 ri
1974 pprInstr (SLW reg1 reg2 ri) = pprLogic SLIT("slw") reg1 reg2 ri
1975 pprInstr (SRW reg1 reg2 ri) = pprLogic SLIT("srw") reg1 reg2 ri
1976 pprInstr (SRAW reg1 reg2 ri) = pprLogic SLIT("sraw") reg1 reg2 ri
1977 pprInstr (NEG reg1 reg2) = pprUnary SLIT("neg") reg1 reg2
1978 pprInstr (NOT reg1 reg2) = pprUnary SLIT("not") reg1 reg2
1979
1980 pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF SLIT("fadd") sz reg1 reg2 reg3
1981 pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF SLIT("fsub") sz reg1 reg2 reg3
1982 pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF SLIT("fmul") sz reg1 reg2 reg3
1983 pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF SLIT("fdiv") sz reg1 reg2 reg3
1984
1985 pprInstr (FCMP reg1 reg2) = hcat [
1986         char '\t',
1987         ptext SLIT("fcmpu\tcr0, "),
1988             -- Note: we're using fcmpu, not fcmpo
1989             -- The difference is with fcmpo, compare with NaN is an invalid operation.
1990             -- We don't handle invalid fp ops, so we don't care
1991         pprReg reg1,
1992         ptext SLIT(", "),
1993         pprReg reg2
1994     ]
1995
1996 pprInstr _ = ptext SLIT("something")
1997
1998 pprLogic op reg1 reg2 ri = hcat [
1999         char '\t',
2000         ptext op,
2001         case ri of
2002             RIReg _ -> empty
2003             RIImm _ -> char 'i',
2004         char '\t',
2005         pprReg reg1,
2006         ptext SLIT(", "),
2007         pprReg reg2,
2008         ptext SLIT(", "),
2009         pprRI ri
2010     ]
2011
2012 pprUnary op reg1 reg2 = hcat [
2013         char '\t',
2014         ptext op,
2015         char '\t',
2016         pprReg reg1,
2017         ptext SLIT(", "),
2018         pprReg reg2
2019     ]
2020
2021 pprBinaryF op sz reg1 reg2 reg3 = hcat [
2022         char '\t',
2023         ptext op,
2024         pprFSize sz,
2025         char '\t',
2026         pprReg reg1,
2027         ptext SLIT(", "),
2028         pprReg reg2,
2029         ptext SLIT(", "),
2030         pprReg reg3
2031     ]
2032
2033 pprRI :: RI -> Doc
2034 pprRI (RIReg r) = pprReg r
2035 pprRI (RIImm r) = pprImm r
2036
2037 pprFSize DF = empty
2038 pprFSize F = char 's'
2039
2040 #endif {-powerpc_TARGET_ARCH-}
2041 \end{code}
2042
2043 \begin{code}
2044 #if __GLASGOW_HASKELL__ >= 504
2045 newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
2046 newFloatArray = newArray_
2047
2048 newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
2049 newDoubleArray = newArray_
2050
2051 castFloatToCharArray :: STUArray s Int Float -> ST s (STUArray s Int Word8)
2052 castFloatToCharArray = castSTUArray
2053
2054 castDoubleToCharArray :: STUArray s Int Double -> ST s (STUArray s Int Word8)
2055 castDoubleToCharArray = castSTUArray
2056
2057 writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
2058 writeFloatArray = writeArray
2059
2060 writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
2061 writeDoubleArray = writeArray
2062
2063 readCharArray :: STUArray s Int Word8 -> Int -> ST s Char
2064 readCharArray arr i = do
2065   w <- readArray arr i
2066   return $! (chr (fromIntegral w))
2067
2068 #else
2069
2070 castFloatToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2071 castFloatToCharArray = return
2072
2073 castDoubleToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2074
2075
2076 castDoubleToCharArray = return
2077
2078 #endif
2079
2080 -- floatToBytes and doubleToBytes convert to the host's byte
2081 -- order.  Providing that we're not cross-compiling for a
2082 -- target with the opposite endianness, this should work ok
2083 -- on all targets.
2084
2085 -- ToDo: this stuff is very similar to the shenanigans in PprAbs,
2086 -- could they be merged?
2087
2088 floatToBytes :: Float -> [Int]
2089 floatToBytes f
2090    = runST (do
2091         arr <- newFloatArray ((0::Int),3)
2092         writeFloatArray arr 0 f
2093         arr <- castFloatToCharArray arr
2094         i0 <- readCharArray arr 0
2095         i1 <- readCharArray arr 1
2096         i2 <- readCharArray arr 2
2097         i3 <- readCharArray arr 3
2098         return (map ord [i0,i1,i2,i3])
2099      )
2100
2101 doubleToBytes :: Double -> [Int]
2102 doubleToBytes d
2103    = runST (do
2104         arr <- newDoubleArray ((0::Int),7)
2105         writeDoubleArray arr 0 d
2106         arr <- castDoubleToCharArray arr
2107         i0 <- readCharArray arr 0
2108         i1 <- readCharArray arr 1
2109         i2 <- readCharArray arr 2
2110         i3 <- readCharArray arr 3
2111         i4 <- readCharArray arr 4
2112         i5 <- readCharArray arr 5
2113         i6 <- readCharArray arr 6
2114         i7 <- readCharArray arr 7
2115         return (map ord [i0,i1,i2,i3,i4,i5,i6,i7])
2116      )
2117 \end{code}