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 \end{code}
 180
 181 %************************************************************************
 182 %*                                                                      *
 183 \subsection{@pprSize@: print a @Size@}
 184 %*                                                                      *
 185 %************************************************************************
 186
 187 \begin{code}
 188 pprSize :: Size -> Doc
 189
 190 pprSize x = ptext (case x of
 191 #if alpha_TARGET_ARCH
 192          B  -> SLIT("b")
 193          Bu -> SLIT("bu")
 194 --       W  -> SLIT("w") UNUSED
 195 --       Wu -> SLIT("wu") UNUSED
 196          L  -> SLIT("l")
 197          Q  -> SLIT("q")
 198 --       FF -> SLIT("f") UNUSED
 199 --       DF -> SLIT("d") UNUSED
 200 --       GF -> SLIT("g") UNUSED
 201 --       SF -> SLIT("s") UNUSED
 202          TF -> SLIT("t")
 203 #endif
 204 #if i386_TARGET_ARCH
 205         B   -> SLIT("b")
 206         Bu  -> SLIT("b")
 207         W   -> SLIT("w")
 208         Wu  -> SLIT("w")
 209         L   -> SLIT("l")
 210         Lu  -> SLIT("l")
 211         F   -> SLIT("s")
 212         DF  -> SLIT("l")
 213         F80 -> SLIT("t")
 214 #endif
 215 #if sparc_TARGET_ARCH
 216         B   -> SLIT("sb")
 217         Bu  -> SLIT("ub")
 218         H   -> SLIT("sh")
 219         Hu  -> SLIT("uh")
 220         W   -> SLIT("")
 221         F   -> SLIT("")
 222         DF  -> SLIT("d")
 223     )
 224 pprStSize :: Size -> Doc
 225 pprStSize x = ptext (case x of
 226         B   -> SLIT("b")
 227         Bu  -> SLIT("b")
 228         H   -> SLIT("h")
 229         Hu  -> SLIT("h")
 230         W   -> SLIT("")
 231         F   -> SLIT("")
 232         DF  -> SLIT("d")
 233 #endif
 234     )
 235 \end{code}
 236
 237 %************************************************************************
 238 %*                                                                      *
 239 \subsection{@pprCond@: print a @Cond@}
 240 %*                                                                      *
 241 %************************************************************************
 242
 243 \begin{code}
 244 pprCond :: Cond -> Doc
 245
 246 pprCond c = ptext (case c of {
 247 #if alpha_TARGET_ARCH
 248         EQQ  -> SLIT("eq");
 249         LTT  -> SLIT("lt");
 250         LE  -> SLIT("le");
 251         ULT -> SLIT("ult");
 252         ULE -> SLIT("ule");
 253         NE  -> SLIT("ne");
 254         GTT  -> SLIT("gt");
 255         GE  -> SLIT("ge")
 256 #endif
 257 #if i386_TARGET_ARCH
 258         GEU     -> SLIT("ae");  LU    -> SLIT("b");
 259         EQQ     -> SLIT("e");   GTT    -> SLIT("g");
 260         GE      -> SLIT("ge");  GU    -> SLIT("a");
 261         LTT     -> SLIT("l");   LE    -> SLIT("le");
 262         LEU     -> SLIT("be");  NE    -> SLIT("ne");
 263         NEG     -> SLIT("s");   POS   -> SLIT("ns");
 264         CARRY   -> SLIT("c");   OFLO  -> SLIT("o");
 265         ALWAYS  -> SLIT("mp")   -- hack
 266 #endif
 267 #if sparc_TARGET_ARCH
 268         ALWAYS  -> SLIT("");    NEVER -> SLIT("n");
 269         GEU     -> SLIT("geu"); LU    -> SLIT("lu");
 270         EQQ     -> SLIT("e");   GTT   -> SLIT("g");
 271         GE      -> SLIT("ge");  GU    -> SLIT("gu");
 272         LTT     -> SLIT("l");   LE    -> SLIT("le");
 273         LEU     -> SLIT("leu"); NE    -> SLIT("ne");
 274         NEG     -> SLIT("neg"); POS   -> SLIT("pos");
 275         VC      -> SLIT("vc");  VS    -> SLIT("vs")
 276 #endif
 277     })
 278 \end{code}
 279
 280 %************************************************************************
 281 %*                                                                      *
 282 \subsection{@pprImm@: print an @Imm@}
 283 %*                                                                      *
 284 %************************************************************************
 285
 286 \begin{code}
 287 pprImm :: Imm -> Doc
 288
 289 pprImm (ImmInt i)     = int i
 290 pprImm (ImmInteger i) = integer i
 291 pprImm (ImmCLbl l)    = (if labelDynamic l then text "__imp_" else empty)
 292                         <> pprCLabel_asm l
 293 pprImm (ImmIndex l i) = (if labelDynamic l then text "__imp_" else empty)
 294                         <> pprCLabel_asm l <> char '+' <> int i
 295 pprImm (ImmLit s)     = s
 296
 297 pprImm (ImmLab dll s) = (if underscorePrefix then char '_' else empty)
 298                         <> (if dll then text "_imp__" else empty)
 299                         <> s
 300
 301 #if sparc_TARGET_ARCH
 302 pprImm (LO i)
 303   = hcat [ pp_lo, pprImm i, rparen ]
 304   where
 305     pp_lo = text "%lo("
 306
 307 pprImm (HI i)
 308   = hcat [ pp_hi, pprImm i, rparen ]
 309   where
 310     pp_hi = text "%hi("
 311 #endif
 312 \end{code}
 313
 314 %************************************************************************
 315 %*                                                                      *
 316 \subsection{@pprAddr@: print an @Addr@}
 317 %*                                                                      *
 318 %************************************************************************
 319
 320 \begin{code}
 321 pprAddr :: MachRegsAddr -> Doc
 322
 323 #if alpha_TARGET_ARCH
 324 pprAddr (AddrReg r) = parens (pprReg r)
 325 pprAddr (AddrImm i) = pprImm i
 326 pprAddr (AddrRegImm r1 i)
 327   = (<>) (pprImm i) (parens (pprReg r1))
 328 #endif
 329
 330 -------------------
 331
 332 #if i386_TARGET_ARCH
 333 pprAddr (ImmAddr imm off)
 334   = let pp_imm = pprImm imm
 335     in
 336     if (off == 0) then
 337         pp_imm
 338     else if (off < 0) then
 339         pp_imm <> int off
 340     else
 341         pp_imm <> char '+' <> int off
 342
 343 pprAddr (AddrBaseIndex base index displacement)
 344   = let
 345         pp_disp  = ppr_disp displacement
 346         pp_off p = pp_disp <> char '(' <> p <> char ')'
 347         pp_reg r = pprReg L r
 348     in
 349     case (base,index) of
 350       (Nothing, Nothing)    -> pp_disp
 351       (Just b,  Nothing)    -> pp_off (pp_reg b)
 352       (Nothing, Just (r,i)) -> pp_off (pp_reg r <> comma <> int i)
 353       (Just b,  Just (r,i)) -> pp_off (pp_reg b <> comma <> pp_reg r
 354                                        <> comma <> int i)
 355   where
 356     ppr_disp (ImmInt 0) = empty
 357     ppr_disp imm        = pprImm imm
 358 #endif
 359
 360 -------------------
 361
 362 #if sparc_TARGET_ARCH
 363 pprAddr (AddrRegReg r1 (RealReg 0)) = pprReg r1
 364
 365 pprAddr (AddrRegReg r1 r2)
 366   = hcat [ pprReg r1, char '+', pprReg r2 ]
 367
 368 pprAddr (AddrRegImm r1 (ImmInt i))
 369   | i == 0 = pprReg r1
 370   | not (fits13Bits i) = largeOffsetError i
 371   | otherwise = hcat [ pprReg r1, pp_sign, int i ]
 372   where
 373     pp_sign = if i > 0 then char '+' else empty
 374
 375 pprAddr (AddrRegImm r1 (ImmInteger i))
 376   | i == 0 = pprReg r1
 377   | not (fits13Bits i) = largeOffsetError i
 378   | otherwise  = hcat [ pprReg r1, pp_sign, integer i ]
 379   where
 380     pp_sign = if i > 0 then char '+' else empty
 381
 382 pprAddr (AddrRegImm r1 imm)
 383   = hcat [ pprReg r1, char '+', pprImm imm ]
 384 #endif
 385 \end{code}
 386
 387 %************************************************************************
 388 %*                                                                      *
 389 \subsection{@pprInstr@: print an @Instr@}
 390 %*                                                                      *
 391 %************************************************************************
 392
 393 \begin{code}
 394 pprInstr :: Instr -> Doc
 395
 396 --pprInstr (COMMENT s) = empty -- nuke 'em
 397 pprInstr (COMMENT s)
 398    =  IF_ARCH_alpha( ((<>) (ptext SLIT("\t# ")) (ftext s))
 399      ,IF_ARCH_sparc( ((<>) (ptext SLIT("! "))   (ftext s))
 400      ,IF_ARCH_i386( ((<>) (ptext SLIT("# "))   (ftext s))
 401      ,)))
 402
 403 pprInstr (DELTA d)
 404    = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
 405
 406 pprInstr (SEGMENT TextSegment)
 407     =  IF_ARCH_alpha(ptext SLIT("\t.text\n\t.align 3") {-word boundary-}
 408       ,IF_ARCH_sparc(ptext SLIT(".text\n\t.align 4") {-word boundary-}
 409       ,IF_ARCH_i386((text ".text\n\t.align 4,0x90") {-needs per-OS variation!-}
 410       ,)))
 411
 412 pprInstr (SEGMENT DataSegment)
 413     = ptext
 414          IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
 415         ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
 416         ,IF_ARCH_i386(SLIT(".data\n\t.align 4")
 417         ,)))
 418
 419 pprInstr (SEGMENT RoDataSegment)
 420     = ptext
 421          IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
 422         ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
 423         ,IF_ARCH_i386(SLIT(".section .rodata\n\t.align 4")
 424         ,)))
 425
 426 pprInstr (LABEL clab)
 427   = let
 428         pp_lab = pprCLabel_asm clab
 429     in
 430     hcat [
 431         if not (externallyVisibleCLabel clab) then
 432             empty
 433         else
 434             hcat [ptext
 435                          IF_ARCH_alpha(SLIT("\t.globl\t")
 436                         ,IF_ARCH_i386(SLIT(".globl ")
 437                         ,IF_ARCH_sparc(SLIT(".global\t")
 438                         ,)))
 439                         , pp_lab, char '\n'],
 440         pp_lab,
 441         char ':'
 442     ]
 443
 444 pprInstr (ASCII False{-no backslash conversion-} str)
 445   = hcat [ ptext SLIT("\t.asciz "), char '\"', text str, char '"' ]
 446
 447 pprInstr (ASCII True str)
 448   = vcat (map do1 (str ++ [chr 0]))
 449     where
 450        do1 :: Char -> Doc
 451        do1 c = ptext SLIT("\t.byte\t0x") <> hshow (ord c)
 452
 453        hshow :: Int -> Doc
 454        hshow n | n >= 0 && n <= 255
 455                = char (tab !! (n `div` 16)) <> char (tab !! (n `mod` 16))
 456        tab = "0123456789ABCDEF"
 457
 458
 459 pprInstr (DATA s xs)
 460   = vcat (concatMap (ppr_item s) xs)
 461     where
 462
 463 #if alpha_TARGET_ARCH
 464             ppr_item = error "ppr_item on Alpha"
 465 #endif
 466 #if sparc_TARGET_ARCH
 467         -- copy n paste of x86 version
 468         ppr_item B  x = [ptext SLIT("\t.byte\t") <> pprImm x]
 469         ppr_item W  x = [ptext SLIT("\t.long\t") <> pprImm x]
 470         ppr_item F  (ImmFloat r)
 471            = let bs = floatToBytes (fromRational r)
 472              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 473         ppr_item DF (ImmDouble r)
 474            = let bs = doubleToBytes (fromRational r)
 475              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 476 #endif
 477 #if i386_TARGET_ARCH
 478         ppr_item B  x = [ptext SLIT("\t.byte\t") <> pprImm x]
 479         ppr_item L  x = [ptext SLIT("\t.long\t") <> pprImm x]
 480         ppr_item F  (ImmFloat r)
 481            = let bs = floatToBytes (fromRational r)
 482              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 483         ppr_item DF (ImmDouble r)
 484            = let bs = doubleToBytes (fromRational r)
 485              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 486 #endif
 487
 488 -- fall through to rest of (machine-specific) pprInstr...
 489 \end{code}
 490
 491 %************************************************************************
 492 %*                                                                      *
 493 \subsubsection{@pprInstr@ for an Alpha}
 494 %*                                                                      *
 495 %************************************************************************
 496
 497 \begin{code}
 498 #if alpha_TARGET_ARCH
 499
 500 pprInstr (LD size reg addr)
 501   = hcat [
 502         ptext SLIT("\tld"),
 503         pprSize size,
 504         char '\t',
 505         pprReg reg,
 506         comma,
 507         pprAddr addr
 508     ]
 509
 510 pprInstr (LDA reg addr)
 511   = hcat [
 512         ptext SLIT("\tlda\t"),
 513         pprReg reg,
 514         comma,
 515         pprAddr addr
 516     ]
 517
 518 pprInstr (LDAH reg addr)
 519   = hcat [
 520         ptext SLIT("\tldah\t"),
 521         pprReg reg,
 522         comma,
 523         pprAddr addr
 524     ]
 525
 526 pprInstr (LDGP reg addr)
 527   = hcat [
 528         ptext SLIT("\tldgp\t"),
 529         pprReg reg,
 530         comma,
 531         pprAddr addr
 532     ]
 533
 534 pprInstr (LDI size reg imm)
 535   = hcat [
 536         ptext SLIT("\tldi"),
 537         pprSize size,
 538         char '\t',
 539         pprReg reg,
 540         comma,
 541         pprImm imm
 542     ]
 543
 544 pprInstr (ST size reg addr)
 545   = hcat [
 546         ptext SLIT("\tst"),
 547         pprSize size,
 548         char '\t',
 549         pprReg reg,
 550         comma,
 551         pprAddr addr
 552     ]
 553
 554 pprInstr (CLR reg)
 555   = hcat [
 556         ptext SLIT("\tclr\t"),
 557         pprReg reg
 558     ]
 559
 560 pprInstr (ABS size ri reg)
 561   = hcat [
 562         ptext SLIT("\tabs"),
 563         pprSize size,
 564         char '\t',
 565         pprRI ri,
 566         comma,
 567         pprReg reg
 568     ]
 569
 570 pprInstr (NEG size ov ri reg)
 571   = hcat [
 572         ptext SLIT("\tneg"),
 573         pprSize size,
 574         if ov then ptext SLIT("v\t") else char '\t',
 575         pprRI ri,
 576         comma,
 577         pprReg reg
 578     ]
 579
 580 pprInstr (ADD size ov reg1 ri reg2)
 581   = hcat [
 582         ptext SLIT("\tadd"),
 583         pprSize size,
 584         if ov then ptext SLIT("v\t") else char '\t',
 585         pprReg reg1,
 586         comma,
 587         pprRI ri,
 588         comma,
 589         pprReg reg2
 590     ]
 591
 592 pprInstr (SADD size scale reg1 ri reg2)
 593   = hcat [
 594         ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
 595         ptext SLIT("add"),
 596         pprSize size,
 597         char '\t',
 598         pprReg reg1,
 599         comma,
 600         pprRI ri,
 601         comma,
 602         pprReg reg2
 603     ]
 604
 605 pprInstr (SUB size ov reg1 ri reg2)
 606   = hcat [
 607         ptext SLIT("\tsub"),
 608         pprSize size,
 609         if ov then ptext SLIT("v\t") else char '\t',
 610         pprReg reg1,
 611         comma,
 612         pprRI ri,
 613         comma,
 614         pprReg reg2
 615     ]
 616
 617 pprInstr (SSUB size scale reg1 ri reg2)
 618   = hcat [
 619         ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
 620         ptext SLIT("sub"),
 621         pprSize size,
 622         char '\t',
 623         pprReg reg1,
 624         comma,
 625         pprRI ri,
 626         comma,
 627         pprReg reg2
 628     ]
 629
 630 pprInstr (MUL size ov reg1 ri reg2)
 631   = hcat [
 632         ptext SLIT("\tmul"),
 633         pprSize size,
 634         if ov then ptext SLIT("v\t") else char '\t',
 635         pprReg reg1,
 636         comma,
 637         pprRI ri,
 638         comma,
 639         pprReg reg2
 640     ]
 641
 642 pprInstr (DIV size uns reg1 ri reg2)
 643   = hcat [
 644         ptext SLIT("\tdiv"),
 645         pprSize size,
 646         if uns then ptext SLIT("u\t") else char '\t',
 647         pprReg reg1,
 648         comma,
 649         pprRI ri,
 650         comma,
 651         pprReg reg2
 652     ]
 653
 654 pprInstr (REM size uns reg1 ri reg2)
 655   = hcat [
 656         ptext SLIT("\trem"),
 657         pprSize size,
 658         if uns then ptext SLIT("u\t") else char '\t',
 659         pprReg reg1,
 660         comma,
 661         pprRI ri,
 662         comma,
 663         pprReg reg2
 664     ]
 665
 666 pprInstr (NOT ri reg)
 667   = hcat [
 668         ptext SLIT("\tnot"),
 669         char '\t',
 670         pprRI ri,
 671         comma,
 672         pprReg reg
 673     ]
 674
 675 pprInstr (AND reg1 ri reg2) = pprRegRIReg SLIT("and") reg1 ri reg2
 676 pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg SLIT("andnot") reg1 ri reg2
 677 pprInstr (OR reg1 ri reg2) = pprRegRIReg SLIT("or") reg1 ri reg2
 678 pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg SLIT("ornot") reg1 ri reg2
 679 pprInstr (XOR reg1 ri reg2) = pprRegRIReg SLIT("xor") reg1 ri reg2
 680 pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg SLIT("xornot") reg1 ri reg2
 681
 682 pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") reg1 ri reg2
 683 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") reg1 ri reg2
 684 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") reg1 ri reg2
 685
 686 pprInstr (ZAP reg1 ri reg2) = pprRegRIReg SLIT("zap") reg1 ri reg2
 687 pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg SLIT("zapnot") reg1 ri reg2
 688
 689 pprInstr (NOP) = ptext SLIT("\tnop")
 690
 691 pprInstr (CMP cond reg1 ri reg2)
 692   = hcat [
 693         ptext SLIT("\tcmp"),
 694         pprCond cond,
 695         char '\t',
 696         pprReg reg1,
 697         comma,
 698         pprRI ri,
 699         comma,
 700         pprReg reg2
 701     ]
 702
 703 pprInstr (FCLR reg)
 704   = hcat [
 705         ptext SLIT("\tfclr\t"),
 706         pprReg reg
 707     ]
 708
 709 pprInstr (FABS reg1 reg2)
 710   = hcat [
 711         ptext SLIT("\tfabs\t"),
 712         pprReg reg1,
 713         comma,
 714         pprReg reg2
 715     ]
 716
 717 pprInstr (FNEG size reg1 reg2)
 718   = hcat [
 719         ptext SLIT("\tneg"),
 720         pprSize size,
 721         char '\t',
 722         pprReg reg1,
 723         comma,
 724         pprReg reg2
 725     ]
 726
 727 pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("add") size reg1 reg2 reg3
 728 pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("div") size reg1 reg2 reg3
 729 pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("mul") size reg1 reg2 reg3
 730 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("sub") size reg1 reg2 reg3
 731
 732 pprInstr (CVTxy size1 size2 reg1 reg2)
 733   = hcat [
 734         ptext SLIT("\tcvt"),
 735         pprSize size1,
 736         case size2 of {Q -> ptext SLIT("qc"); _ -> pprSize size2},
 737         char '\t',
 738         pprReg reg1,
 739         comma,
 740         pprReg reg2
 741     ]
 742
 743 pprInstr (FCMP size cond reg1 reg2 reg3)
 744   = hcat [
 745         ptext SLIT("\tcmp"),
 746         pprSize size,
 747         pprCond cond,
 748         char '\t',
 749         pprReg reg1,
 750         comma,
 751         pprReg reg2,
 752         comma,
 753         pprReg reg3
 754     ]
 755
 756 pprInstr (FMOV reg1 reg2)
 757   = hcat [
 758         ptext SLIT("\tfmov\t"),
 759         pprReg reg1,
 760         comma,
 761         pprReg reg2
 762     ]
 763
 764 pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
 765
 766 pprInstr (BI NEVER reg lab) = empty
 767
 768 pprInstr (BI cond reg lab)
 769   = hcat [
 770         ptext SLIT("\tb"),
 771         pprCond cond,
 772         char '\t',
 773         pprReg reg,
 774         comma,
 775         pprImm lab
 776     ]
 777
 778 pprInstr (BF cond reg lab)
 779   = hcat [
 780         ptext SLIT("\tfb"),
 781         pprCond cond,
 782         char '\t',
 783         pprReg reg,
 784         comma,
 785         pprImm lab
 786     ]
 787
 788 pprInstr (BR lab)
 789   = (<>) (ptext SLIT("\tbr\t")) (pprImm lab)
 790
 791 pprInstr (JMP reg addr hint)
 792   = hcat [
 793         ptext SLIT("\tjmp\t"),
 794         pprReg reg,
 795         comma,
 796         pprAddr addr,
 797         comma,
 798         int hint
 799     ]
 800
 801 pprInstr (BSR imm n)
 802   = (<>) (ptext SLIT("\tbsr\t")) (pprImm imm)
 803
 804 pprInstr (JSR reg addr n)
 805   = hcat [
 806         ptext SLIT("\tjsr\t"),
 807         pprReg reg,
 808         comma,
 809         pprAddr addr
 810     ]
 811
 812 pprInstr (FUNBEGIN clab)
 813   = hcat [
 814         if (externallyVisibleCLabel clab) then
 815             hcat [ptext SLIT("\t.globl\t"), pp_lab, char '\n']
 816         else
 817             empty,
 818         ptext SLIT("\t.ent "),
 819         pp_lab,
 820         char '\n',
 821         pp_lab,
 822         pp_ldgp,
 823         pp_lab,
 824         pp_frame
 825     ]
 826     where
 827         pp_lab = pprCLabel_asm clab
 828
 829         -- NEVER use commas within those string literals, cpp will ruin your day
 830         pp_ldgp  = hcat [ ptext SLIT(":\n\tldgp $29"), char ',', ptext SLIT("0($27)\n") ]
 831         pp_frame = hcat [ ptext SLIT("..ng:\n\t.frame $30"), char ',',
 832                           ptext SLIT("4240"), char ',',
 833                           ptext SLIT("$26"), char ',',
 834                           ptext SLIT("0\n\t.prologue 1") ]
 835
 836 pprInstr (FUNEND clab)
 837   = (<>) (ptext SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab)
 838 \end{code}
 839
 840 Continue with Alpha-only printing bits and bobs:
 841 \begin{code}
 842 pprRI :: RI -> Doc
 843
 844 pprRI (RIReg r) = pprReg r
 845 pprRI (RIImm r) = pprImm r
 846
 847 pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
 848 pprRegRIReg name reg1 ri reg2
 849   = hcat [
 850         char '\t',
 851         ptext name,
 852         char '\t',
 853         pprReg reg1,
 854         comma,
 855         pprRI ri,
 856         comma,
 857         pprReg reg2
 858     ]
 859
 860 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
 861 pprSizeRegRegReg name size reg1 reg2 reg3
 862   = hcat [
 863         char '\t',
 864         ptext name,
 865         pprSize size,
 866         char '\t',
 867         pprReg reg1,
 868         comma,
 869         pprReg reg2,
 870         comma,
 871         pprReg reg3
 872     ]
 873
 874 #endif {-alpha_TARGET_ARCH-}
 875 \end{code}
 876
 877 %************************************************************************
 878 %*                                                                      *
 879 \subsubsection{@pprInstr@ for an I386}
 880 %*                                                                      *
 881 %************************************************************************
 882
 883 \begin{code}
 884 #if i386_TARGET_ARCH
 885
 886 pprInstr v@(MOV size s@(OpReg src) d@(OpReg dst)) -- hack
 887   | src == dst
 888   =
 889 #if 0 /* #ifdef DEBUG */
 890     (<>) (ptext SLIT("# warning: ")) (pprSizeOpOp SLIT("mov") size s d)
 891 #else
 892     empty
 893 #endif
 894 pprInstr (MOV size src dst)
 895   = pprSizeOpOp SLIT("mov") size src dst
 896 pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce SLIT("movz") sizes L src dst
 897 pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce SLIT("movs") sizes L src dst
 898
 899 -- here we do some patching, since the physical registers are only set late
 900 -- in the code generation.
 901 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
 902   | reg1 == reg3
 903   = pprSizeOpOp SLIT("add") size (OpReg reg2) dst
 904 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
 905   | reg2 == reg3
 906   = pprSizeOpOp SLIT("add") size (OpReg reg1) dst
 907 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(Just reg1) Nothing displ)) dst@(OpReg reg3))
 908   | reg1 == reg3
 909   = pprInstr (ADD size (OpImm displ) dst)
 910 pprInstr (LEA size src dst) = pprSizeOpOp SLIT("lea") size src dst
 911
 912 pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
 913   = pprSizeOp SLIT("dec") size dst
 914 pprInstr (ADD size (OpImm (ImmInt 1)) dst)
 915   = pprSizeOp SLIT("inc") size dst
 916 pprInstr (ADD size src dst)
 917   = pprSizeOpOp SLIT("add") size src dst
 918 pprInstr (SUB size src dst) = pprSizeOpOp SLIT("sub") size src dst
 919 pprInstr (IMUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2
 920
 921 {- A hack.  The Intel documentation says that "The two and three
 922    operand forms [of IMUL] may also be used with unsigned operands
 923    because the lower half of the product is the same regardless if
 924    (sic) the operands are signed or unsigned.  The CF and OF flags,
 925    however, cannot be used to determine if the upper half of the
 926    result is non-zero."  So there.
 927 -}
 928 pprInstr (MUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2
 929
 930 pprInstr (AND size src dst) = pprSizeOpOp SLIT("and") size src dst
 931 pprInstr (OR  size src dst) = pprSizeOpOp SLIT("or")  size src dst
 932 pprInstr (XOR size src dst) = pprSizeOpOp SLIT("xor")  size src dst
 933 pprInstr (NOT size op) = pprSizeOp SLIT("not") size op
 934 pprInstr (NEGI size op) = pprSizeOp SLIT("neg") size op
 935
 936 pprInstr (SHL size imm dst) = pprSizeImmOp SLIT("shl") size imm dst
 937 pprInstr (SAR size imm dst) = pprSizeImmOp SLIT("sar") size imm dst
 938 pprInstr (SHR size imm dst) = pprSizeImmOp SLIT("shr") size imm dst
 939 pprInstr (BT  size imm src) = pprSizeImmOp SLIT("bt")  size imm src
 940
 941 pprInstr (CMP size src dst) = pprSizeOpOp SLIT("cmp")  size src dst
 942 pprInstr (TEST size src dst) = pprSizeOpOp SLIT("test")  size src dst
 943 pprInstr (PUSH size op) = pprSizeOp SLIT("push") size op
 944 pprInstr (POP size op) = pprSizeOp SLIT("pop") size op
 945 pprInstr PUSHA = ptext SLIT("\tpushal")
 946 pprInstr POPA = ptext SLIT("\tpopal")
 947
 948 pprInstr NOP = ptext SLIT("\tnop")
 949 pprInstr CLTD = ptext SLIT("\tcltd")
 950
 951 pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand B op)
 952
 953 pprInstr (JXX cond lab) = pprCondInstr SLIT("j") cond (pprCLabel_asm lab)
 954
 955 pprInstr (JMP dsts (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
 956 pprInstr (JMP dsts op)          = (<>) (ptext SLIT("\tjmp *")) (pprOperand L op)
 957 pprInstr (CALL (Left imm))      = (<>) (ptext SLIT("\tcall ")) (pprImm imm)
 958 pprInstr (CALL (Right reg))     = (<>) (ptext SLIT("\tcall *")) (pprReg L reg)
 959
 960 -- First bool indicates signedness; second whether quot or rem
 961 pprInstr (IQUOT sz src dst) = pprInstr_quotRem True True sz src dst
 962 pprInstr (IREM  sz src dst) = pprInstr_quotRem True False sz src dst
 963
 964 pprInstr (QUOT sz src dst) = pprInstr_quotRem False True sz src dst
 965 pprInstr (REM  sz src dst) = pprInstr_quotRem False False sz src dst
 966
 967 pprInstr (IMUL64 sd_hi sd_lo) = pprInstr_imul64 sd_hi sd_lo
 968
 969
 970 -- Simulating a flat register set on the x86 FP stack is tricky.
 971 -- you have to free %st(7) before pushing anything on the FP reg stack
 972 -- so as to preclude the possibility of a FP stack overflow exception.
 973 pprInstr g@(GMOV src dst)
 974    | src == dst
 975    = empty
 976    | otherwise
 977    = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
 978
 979 -- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FSTP (dst+1)
 980 pprInstr g@(GLD sz addr dst)
 981  = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp,
 982                  pprAddr addr, gsemi, gpop dst 1])
 983
 984 -- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
 985 pprInstr g@(GST sz src addr)
 986  = pprG g (hcat [gtab, gpush src 0, gsemi,
 987                  text "fstp", pprSize sz, gsp, pprAddr addr])
 988
 989 pprInstr g@(GLDZ dst)
 990  = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1])
 991 pprInstr g@(GLD1 dst)
 992  = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1])
 993
 994 pprInstr g@(GFTOI src dst)
 995    = pprInstr (GDTOI src dst)
 996 pprInstr g@(GDTOI src dst)
 997    = pprG g (hcat [gtab, text "subl $4, %esp ; ",
 998                    gpush src 0, gsemi, text "fistpl 0(%esp) ; popl ",
 999                    pprReg L dst])
1000
1001 pprInstr g@(GITOF src dst)
1002    = pprInstr (GITOD src dst)
1003 pprInstr g@(GITOD src dst)
1004    = pprG g (hcat [gtab, text "pushl ", pprReg L src,
1005                    text " ; ffree %st(7); fildl (%esp) ; ",
1006                    gpop dst 1, text " ; addl $4,%esp"])
1007
1008 {- Gruesome swamp follows.  If you're unfortunate enough to have ventured
1009    this far into the jungle AND you give a Rat's Ass (tm) what's going
1010    on, here's the deal.  Generate code to do a floating point comparison
1011    of src1 and src2, of kind cond, and set the Zero flag if true.
1012
1013    The complications are to do with handling NaNs correctly.  We want the
1014    property that if either argument is NaN, then the result of the
1015    comparison is False ... except if we're comparing for inequality,
1016    in which case the answer is True.
1017
1018    Here's how the general (non-inequality) case works.  As an
1019    example, consider generating the an equality test:
1020
1021      pushl %eax         -- we need to mess with this
1022      <get src1 to top of FPU stack>
1023      fcomp <src2 location in FPU stack> and pop pushed src1
1024                 -- Result of comparison is in FPU Status Register bits
1025                 -- C3 C2 and C0
1026      fstsw %ax  -- Move FPU Status Reg to %ax
1027      sahf       -- move C3 C2 C0 from %ax to integer flag reg
1028      -- now the serious magic begins
1029      setpo %ah     -- %ah = if comparable(neither arg was NaN) then 1 else 0
1030      sete  %al     -- %al = if arg1 == arg2 then 1 else 0
1031      andb %ah,%al  -- %al &= %ah
1032                    -- so %al == 1 iff (comparable && same); else it holds 0
1033      decb %al      -- %al == 0, ZeroFlag=1  iff (comparable && same);
1034                       else %al == 0xFF, ZeroFlag=0
1035      -- the zero flag is now set as we desire.
1036      popl %eax
1037
1038    The special case of inequality differs thusly:
1039
1040      setpe %ah     -- %ah = if incomparable(either arg was NaN) then 1 else 0
1041      setne %al     -- %al = if arg1 /= arg2 then 1 else 0
1042      orb %ah,%al   -- %al = if (incomparable || different) then 1 else 0
1043      decb %al      -- if (incomparable || different) then (%al == 0, ZF=1)
1044                                                      else (%al == 0xFF, ZF=0)
1045 -}
1046 pprInstr g@(GCMP cond src1 src2)
1047    | case cond of { NE -> True; other -> False }
1048    = pprG g (vcat [
1049         hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1050         hcat [gtab, text "fcomp ", greg src2 1,
1051                     text "; fstsw %ax ; sahf ;  setpe %ah"],
1052         hcat [gtab, text "setne %al ;  ",
1053               text "orb %ah,%al ;  decb %al ;  popl %eax"]
1054     ])
1055    | otherwise
1056    = pprG g (vcat [
1057         hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1058         hcat [gtab, text "fcomp ", greg src2 1,
1059                     text "; fstsw %ax ; sahf ;  setpo %ah"],
1060         hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ;  ",
1061               text "andb %ah,%al ;  decb %al ;  popl %eax"]
1062     ])
1063     where
1064         {- On the 486, the flags set by FP compare are the unsigned ones!
1065            (This looks like a HACK to me.  WDP 96/03)
1066         -}
1067         fix_FP_cond :: Cond -> Cond
1068         fix_FP_cond GE   = GEU
1069         fix_FP_cond GTT  = GU
1070         fix_FP_cond LTT  = LU
1071         fix_FP_cond LE   = LEU
1072         fix_FP_cond EQQ  = EQQ
1073         fix_FP_cond NE   = NE
1074         -- there should be no others
1075
1076
1077 pprInstr g@(GABS sz src dst)
1078    = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
1079 pprInstr g@(GNEG sz src dst)
1080    = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
1081
1082 pprInstr g@(GSQRT sz src dst)
1083    = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
1084              hcat [gtab, gcoerceto sz, gpop dst 1])
1085 pprInstr g@(GSIN sz src dst)
1086    = pprG g (hcat [gtab, gpush src 0, text " ; fsin"] $$
1087              hcat [gtab, gcoerceto sz, gpop dst 1])
1088 pprInstr g@(GCOS sz src dst)
1089    = pprG g (hcat [gtab, gpush src 0, text " ; fcos"] $$
1090              hcat [gtab, gcoerceto sz, gpop dst 1])
1091 pprInstr g@(GTAN sz src dst)
1092    = pprG g (hcat [gtab, text "ffree %st(6) ; ",
1093                    gpush src 0, text " ; fptan ; ",
1094                    text " fstp %st(0)"] $$
1095              hcat [gtab, gcoerceto sz, gpop dst 1])
1096
1097 -- In the translations for GADD, GMUL, GSUB and GDIV,
1098 -- the first two cases are mere optimisations.  The otherwise clause
1099 -- generates correct code under all circumstances.
1100
1101 pprInstr g@(GADD sz src1 src2 dst)
1102    | src1 == dst
1103    = pprG g (text "\t#GADD-xxxcase1" $$
1104              hcat [gtab, gpush src2 0,
1105                    text " ; faddp %st(0),", greg src1 1])
1106    | src2 == dst
1107    = pprG g (text "\t#GADD-xxxcase2" $$
1108              hcat [gtab, gpush src1 0,
1109                    text " ; faddp %st(0),", greg src2 1])
1110    | otherwise
1111    = pprG g (hcat [gtab, gpush src1 0,
1112                    text " ; fadd ", greg src2 1, text ",%st(0)",
1113                    gsemi, gpop dst 1])
1114
1115
1116 pprInstr g@(GMUL sz src1 src2 dst)
1117    | src1 == dst
1118    = pprG g (text "\t#GMUL-xxxcase1" $$
1119              hcat [gtab, gpush src2 0,
1120                    text " ; fmulp %st(0),", greg src1 1])
1121    | src2 == dst
1122    = pprG g (text "\t#GMUL-xxxcase2" $$
1123              hcat [gtab, gpush src1 0,
1124                    text " ; fmulp %st(0),", greg src2 1])
1125    | otherwise
1126    = pprG g (hcat [gtab, gpush src1 0,
1127                    text " ; fmul ", greg src2 1, text ",%st(0)",
1128                    gsemi, gpop dst 1])
1129
1130
1131 pprInstr g@(GSUB sz src1 src2 dst)
1132    | src1 == dst
1133    = pprG g (text "\t#GSUB-xxxcase1" $$
1134              hcat [gtab, gpush src2 0,
1135                    text " ; fsubrp %st(0),", greg src1 1])
1136    | src2 == dst
1137    = pprG g (text "\t#GSUB-xxxcase2" $$
1138              hcat [gtab, gpush src1 0,
1139                    text " ; fsubp %st(0),", greg src2 1])
1140    | otherwise
1141    = pprG g (hcat [gtab, gpush src1 0,
1142                    text " ; fsub ", greg src2 1, text ",%st(0)",
1143                    gsemi, gpop dst 1])
1144
1145
1146 pprInstr g@(GDIV sz src1 src2 dst)
1147    | src1 == dst
1148    = pprG g (text "\t#GDIV-xxxcase1" $$
1149              hcat [gtab, gpush src2 0,
1150                    text " ; fdivrp %st(0),", greg src1 1])
1151    | src2 == dst
1152    = pprG g (text "\t#GDIV-xxxcase2" $$
1153              hcat [gtab, gpush src1 0,
1154                    text " ; fdivp %st(0),", greg src2 1])
1155    | otherwise
1156    = pprG g (hcat [gtab, gpush src1 0,
1157                    text " ; fdiv ", greg src2 1, text ",%st(0)",
1158                    gsemi, gpop dst 1])
1159
1160
1161 pprInstr GFREE
1162    = vcat [ ptext SLIT("\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
1163             ptext SLIT("\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)")
1164           ]
1165
1166
1167 pprInstr_quotRem signed isQuot sz src dst
1168    | case sz of L -> False; _ -> True
1169    = panic "pprInstr_quotRem: dunno how to do non-32bit operands"
1170    | otherwise
1171    = vcat [
1172      (text "\t# BEGIN " <> fakeInsn),
1173      (text "\tpushl $0;  pushl %eax;  pushl %edx;  pushl " <> pprOperand sz src),
1174      (text "\tmovl " <> pprOperand sz dst <> text ",%eax;  " <> widen_to_64),
1175      (x86op <> text " 0(%esp);  movl " <> text resReg <> text ",12(%esp)"),
1176      (text "\tpopl %edx;  popl %edx;  popl %eax;  popl " <> pprOperand sz dst),
1177      (text "\t# END   " <> fakeInsn)
1178      ]
1179      where
1180         widen_to_64 | signed     = text "cltd"
1181                     | not signed = text "xorl %edx,%edx"
1182         x86op = if signed then text "\tidivl" else text "\tdivl"
1183         resReg = if isQuot then "%eax" else "%edx"
1184         opStr  | signed     = if isQuot then "IQUOT" else "IREM"
1185                | not signed = if isQuot then "QUOT"  else "REM"
1186         fakeInsn = text opStr <+> pprOperand sz src
1187                               <> char ',' <+> pprOperand sz dst
1188
1189 -- Emit code to make hi_reg:lo_reg be the 64-bit product of hi_reg and lo_reg
1190 pprInstr_imul64 hi_reg lo_reg
1191    = let fakeInsn = text "imul64" <+> pp_hi_reg <> comma <+> pp_lo_reg
1192          pp_hi_reg = pprReg L hi_reg
1193          pp_lo_reg = pprReg L lo_reg
1194      in
1195          vcat [
1196             text "\t# BEGIN " <> fakeInsn,
1197             text "\tpushl" <+> pp_hi_reg <> text" ;  pushl" <+> pp_lo_reg,
1198             text "\tpushl %eax ; pushl %edx",
1199             text "\tmovl 12(%esp), %eax ; imull 8(%esp)",
1200             text "\tmovl %edx, 12(%esp) ; movl %eax, 8(%esp)",
1201             text "\tpopl %edx ; popl %eax",
1202             text "\tpopl" <+> pp_lo_reg <> text " ;  popl" <+> pp_hi_reg,
1203             text "\t# END   " <> fakeInsn
1204          ]
1205
1206
1207 --------------------------
1208
1209 -- coerce %st(0) to the specified size
1210 gcoerceto DF = empty
1211 gcoerceto  F = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
1212
1213 gpush reg offset
1214    = hcat [text "ffree %st(7) ; fld ", greg reg offset]
1215 gpop reg offset
1216    = hcat [text "fstp ", greg reg offset]
1217
1218 bogus = text "\tbogus"
1219 greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
1220 gsemi = text " ; "
1221 gtab  = char '\t'
1222 gsp   = char ' '
1223
1224 gregno (RealReg i) = i
1225 gregno other       = --pprPanic "gregno" (ppr other)
1226                      999   -- bogus; only needed for debug printing
1227
1228 pprG :: Instr -> Doc -> Doc
1229 pprG fake actual
1230    = (char '#' <> pprGInstr fake) $$ actual
1231
1232 pprGInstr (GMOV src dst)   = pprSizeRegReg SLIT("gmov") DF src dst
1233 pprGInstr (GLD sz src dst) = pprSizeAddrReg SLIT("gld") sz src dst
1234 pprGInstr (GST sz src dst) = pprSizeRegAddr SLIT("gst") sz src dst
1235
1236 pprGInstr (GLDZ dst) = pprSizeReg SLIT("gldz") DF dst
1237 pprGInstr (GLD1 dst) = pprSizeReg SLIT("gld1") DF dst
1238
1239 pprGInstr (GFTOI src dst) = pprSizeSizeRegReg SLIT("gftoi") F L  src dst
1240 pprGInstr (GDTOI src dst) = pprSizeSizeRegReg SLIT("gdtoi") DF L src dst
1241
1242 pprGInstr (GITOF src dst) = pprSizeSizeRegReg SLIT("gitof") L F  src dst
1243 pprGInstr (GITOD src dst) = pprSizeSizeRegReg SLIT("gitod") L DF src dst
1244
1245 pprGInstr (GCMP co src dst) = pprCondRegReg SLIT("gcmp_") DF co src dst
1246 pprGInstr (GABS sz src dst) = pprSizeRegReg SLIT("gabs") sz src dst
1247 pprGInstr (GNEG sz src dst) = pprSizeRegReg SLIT("gneg") sz src dst
1248 pprGInstr (GSQRT sz src dst) = pprSizeRegReg SLIT("gsqrt") sz src dst
1249 pprGInstr (GSIN sz src dst) = pprSizeRegReg SLIT("gsin") sz src dst
1250 pprGInstr (GCOS sz src dst) = pprSizeRegReg SLIT("gcos") sz src dst
1251 pprGInstr (GTAN sz src dst) = pprSizeRegReg SLIT("gtan") sz src dst
1252
1253 pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg SLIT("gadd") sz src1 src2 dst
1254 pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg SLIT("gsub") sz src1 src2 dst
1255 pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg SLIT("gmul") sz src1 src2 dst
1256 pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg SLIT("gdiv") sz src1 src2 dst
1257 \end{code}
1258
1259 Continue with I386-only printing bits and bobs:
1260 \begin{code}
1261 pprDollImm :: Imm -> Doc
1262
1263 pprDollImm i =  ptext SLIT("$") <> pprImm i
1264
1265 pprOperand :: Size -> Operand -> Doc
1266 pprOperand s (OpReg r)   = pprReg s r
1267 pprOperand s (OpImm i)   = pprDollImm i
1268 pprOperand s (OpAddr ea) = pprAddr ea
1269
1270 pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc
1271 pprSizeImmOp name size imm op1
1272   = hcat [
1273         char '\t',
1274         ptext name,
1275         pprSize size,
1276         space,
1277         char '$',
1278         pprImm imm,
1279         comma,
1280         pprOperand size op1
1281     ]
1282
1283 pprSizeOp :: LitString -> Size -> Operand -> Doc
1284 pprSizeOp name size op1
1285   = hcat [
1286         char '\t',
1287         ptext name,
1288         pprSize size,
1289         space,
1290         pprOperand size op1
1291     ]
1292
1293 pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1294 pprSizeOpOp name size op1 op2
1295   = hcat [
1296         char '\t',
1297         ptext name,
1298         pprSize size,
1299         space,
1300         pprOperand size op1,
1301         comma,
1302         pprOperand size op2
1303     ]
1304
1305 pprSizeByteOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1306 pprSizeByteOpOp name size op1 op2
1307   = hcat [
1308         char '\t',
1309         ptext name,
1310         pprSize size,
1311         space,
1312         pprOperand B op1,
1313         comma,
1314         pprOperand size op2
1315     ]
1316
1317 pprSizeOpReg :: LitString -> Size -> Operand -> Reg -> Doc
1318 pprSizeOpReg name size op1 reg
1319   = hcat [
1320         char '\t',
1321         ptext name,
1322         pprSize size,
1323         space,
1324         pprOperand size op1,
1325         comma,
1326         pprReg size reg
1327     ]
1328
1329 pprSizeReg :: LitString -> Size -> Reg -> Doc
1330 pprSizeReg name size reg1
1331   = hcat [
1332         char '\t',
1333         ptext name,
1334         pprSize size,
1335         space,
1336         pprReg size reg1
1337     ]
1338
1339 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
1340 pprSizeRegReg name size reg1 reg2
1341   = hcat [
1342         char '\t',
1343         ptext name,
1344         pprSize size,
1345         space,
1346         pprReg size reg1,
1347         comma,
1348         pprReg size reg2
1349     ]
1350
1351 pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc
1352 pprCondRegReg name size cond reg1 reg2
1353   = hcat [
1354         char '\t',
1355         ptext name,
1356         pprCond cond,
1357         space,
1358         pprReg size reg1,
1359         comma,
1360         pprReg size reg2
1361     ]
1362
1363 pprSizeSizeRegReg :: LitString -> Size -> Size -> Reg -> Reg -> Doc
1364 pprSizeSizeRegReg name size1 size2 reg1 reg2
1365   = hcat [
1366         char '\t',
1367         ptext name,
1368         pprSize size1,
1369         pprSize size2,
1370         space,
1371         pprReg size1 reg1,
1372
1373         comma,
1374         pprReg size2 reg2
1375     ]
1376
1377 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1378 pprSizeRegRegReg name size reg1 reg2 reg3
1379   = hcat [
1380         char '\t',
1381         ptext name,
1382         pprSize size,
1383         space,
1384         pprReg size reg1,
1385         comma,
1386         pprReg size reg2,
1387         comma,
1388         pprReg size reg3
1389     ]
1390
1391 pprSizeAddr :: LitString -> Size -> MachRegsAddr -> Doc
1392 pprSizeAddr name size op
1393   = hcat [
1394         char '\t',
1395         ptext name,
1396         pprSize size,
1397         space,
1398         pprAddr op
1399     ]
1400
1401 pprSizeAddrReg :: LitString -> Size -> MachRegsAddr -> Reg -> Doc
1402 pprSizeAddrReg name size op dst
1403   = hcat [
1404         char '\t',
1405         ptext name,
1406         pprSize size,
1407         space,
1408         pprAddr op,
1409         comma,
1410         pprReg size dst
1411     ]
1412
1413 pprSizeRegAddr :: LitString -> Size -> Reg -> MachRegsAddr -> Doc
1414 pprSizeRegAddr name size src op
1415   = hcat [
1416         char '\t',
1417         ptext name,
1418         pprSize size,
1419         space,
1420         pprReg size src,
1421         comma,
1422         pprAddr op
1423     ]
1424
1425 pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1426 pprOpOp name size op1 op2
1427   = hcat [
1428         char '\t',
1429         ptext name, space,
1430         pprOperand size op1,
1431         comma,
1432         pprOperand size op2
1433     ]
1434
1435 pprSizeOpOpCoerce :: LitString -> Size -> Size -> Operand -> Operand -> Doc
1436 pprSizeOpOpCoerce name size1 size2 op1 op2
1437   = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
1438         pprOperand size1 op1,
1439         comma,
1440         pprOperand size2 op2
1441     ]
1442
1443 pprCondInstr :: LitString -> Cond -> Doc -> Doc
1444 pprCondInstr name cond arg
1445   = hcat [ char '\t', ptext name, pprCond cond, space, arg]
1446
1447 #endif {-i386_TARGET_ARCH-}
1448 \end{code}
1449
1450 %************************************************************************
1451 %*                                                                      *
1452 \subsubsection{@pprInstr@ for a SPARC}
1453 %*                                                                      *
1454 %************************************************************************
1455
1456 \begin{code}
1457 #if sparc_TARGET_ARCH
1458
1459 -- a clumsy hack for now, to handle possible double alignment problems
1460
1461 -- even clumsier, to allow for RegReg regs that show when doing indexed
1462 -- reads (bytearrays).
1463 --
1464
1465 -- Translate to the following:
1466 --    add g1,g2,g1
1467 --    ld  [g1],%fn
1468 --    ld  [g1+4],%f(n+1)
1469 --    sub g1,g2,g1           -- to restore g1
1470 pprInstr (LD DF (AddrRegReg g1 g2) reg)
1471   = vcat [
1472        hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1473        hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg],
1474        hcat [pp_ld_lbracket, pprReg g1, ptext SLIT("+4]"), comma, pprReg (fPair reg)],
1475        hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1476     ]
1477
1478 -- Translate to
1479 --    ld  [addr],%fn
1480 --    ld  [addr+4],%f(n+1)
1481 pprInstr (LD DF addr reg) | isJust off_addr
1482   = vcat [
1483        hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
1484        hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg (fPair reg)]
1485     ]
1486   where
1487     off_addr = addrOffset addr 4
1488     addr2 = case off_addr of Just x -> x
1489
1490
1491 pprInstr (LD size addr reg)
1492   = hcat [
1493        ptext SLIT("\tld"),
1494        pprSize size,
1495        char '\t',
1496        lbrack,
1497        pprAddr addr,
1498        pp_rbracket_comma,
1499        pprReg reg
1500     ]
1501
1502 -- The same clumsy hack as above
1503
1504 -- Translate to the following:
1505 --    add g1,g2,g1
1506 --    st  %fn,[g1]
1507 --    st  %f(n+1),[g1+4]
1508 --    sub g1,g2,g1           -- to restore g1
1509 pprInstr (ST DF reg (AddrRegReg g1 g2))
1510  = vcat [
1511        hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1512        hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1513              pprReg g1, rbrack],
1514        hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1515              pprReg g1, ptext SLIT("+4]")],
1516        hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1517     ]
1518
1519 -- Translate to
1520 --    st  %fn,[addr]
1521 --    st  %f(n+1),[addr+4]
1522 pprInstr (ST DF reg addr) | isJust off_addr
1523  = vcat [
1524       hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1525             pprAddr addr, rbrack],
1526       hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1527             pprAddr addr2, rbrack]
1528     ]
1529   where
1530     off_addr = addrOffset addr 4
1531     addr2 = case off_addr of Just x -> x
1532
1533 -- no distinction is made between signed and unsigned bytes on stores for the
1534 -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
1535 -- so we call a special-purpose pprSize for ST..
1536
1537 pprInstr (ST size reg addr)
1538   = hcat [
1539        ptext SLIT("\tst"),
1540        pprStSize size,
1541        char '\t',
1542        pprReg reg,
1543        pp_comma_lbracket,
1544        pprAddr addr,
1545        rbrack
1546     ]
1547
1548 pprInstr (ADD x cc reg1 ri reg2)
1549   | not x && not cc && riZero ri
1550   = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1551   | otherwise
1552   = pprRegRIReg (if x then SLIT("addx") else SLIT("add")) cc reg1 ri reg2
1553
1554 pprInstr (SUB x cc reg1 ri reg2)
1555   | not x && cc && reg2 == g0
1556   = hcat [ ptext SLIT("\tcmp\t"), pprReg reg1, comma, pprRI ri ]
1557   | not x && not cc && riZero ri
1558   = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1559   | otherwise
1560   = pprRegRIReg (if x then SLIT("subx") else SLIT("sub")) cc reg1 ri reg2
1561
1562 pprInstr (AND  b reg1 ri reg2) = pprRegRIReg SLIT("and")  b reg1 ri reg2
1563 pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg SLIT("andn") b reg1 ri reg2
1564
1565 pprInstr (OR b reg1 ri reg2)
1566   | not b && reg1 == g0
1567   = let doit = hcat [ ptext SLIT("\tmov\t"), pprRI ri, comma, pprReg reg2 ]
1568     in  case ri of
1569            RIReg rrr | rrr == reg2 -> empty
1570            other                   -> doit
1571   | otherwise
1572   = pprRegRIReg SLIT("or") b reg1 ri reg2
1573
1574 pprInstr (ORN b reg1 ri reg2) = pprRegRIReg SLIT("orn") b reg1 ri reg2
1575
1576 pprInstr (XOR  b reg1 ri reg2) = pprRegRIReg SLIT("xor")  b reg1 ri reg2
1577 pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg SLIT("xnor") b reg1 ri reg2
1578
1579 pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") False reg1 ri reg2
1580 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") False reg1 ri reg2
1581 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") False reg1 ri reg2
1582
1583 pprInstr (RDY rd) = ptext SLIT("\trd\t%y,") <> pprReg rd
1584 pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg SLIT("smul")  b reg1 ri reg2
1585 pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg SLIT("umul")  b reg1 ri reg2
1586
1587 pprInstr (SETHI imm reg)
1588   = hcat [
1589         ptext SLIT("\tsethi\t"),
1590         pprImm imm,
1591         comma,
1592         pprReg reg
1593     ]
1594
1595 pprInstr NOP = ptext SLIT("\tnop")
1596
1597 pprInstr (FABS F reg1 reg2) = pprSizeRegReg SLIT("fabs") F reg1 reg2
1598 pprInstr (FABS DF reg1 reg2)
1599   = (<>) (pprSizeRegReg SLIT("fabs") F reg1 reg2)
1600     (if (reg1 == reg2) then empty
1601      else (<>) (char '\n')
1602           (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
1603
1604 pprInstr (FADD size reg1 reg2 reg3)
1605   = pprSizeRegRegReg SLIT("fadd") size reg1 reg2 reg3
1606 pprInstr (FCMP e size reg1 reg2)
1607   = pprSizeRegReg (if e then SLIT("fcmpe") else SLIT("fcmp")) size reg1 reg2
1608 pprInstr (FDIV size reg1 reg2 reg3)
1609   = pprSizeRegRegReg SLIT("fdiv") size reg1 reg2 reg3
1610
1611 pprInstr (FMOV F reg1 reg2) = pprSizeRegReg SLIT("fmov") F reg1 reg2
1612 pprInstr (FMOV DF reg1 reg2)
1613   = (<>) (pprSizeRegReg SLIT("fmov") F reg1 reg2)
1614     (if (reg1 == reg2) then empty
1615      else (<>) (char '\n')
1616           (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
1617
1618 pprInstr (FMUL size reg1 reg2 reg3)
1619   = pprSizeRegRegReg SLIT("fmul") size reg1 reg2 reg3
1620
1621 pprInstr (FNEG F reg1 reg2) = pprSizeRegReg SLIT("fneg") F reg1 reg2
1622 pprInstr (FNEG DF reg1 reg2)
1623   = (<>) (pprSizeRegReg SLIT("fneg") F reg1 reg2)
1624     (if (reg1 == reg2) then empty
1625      else (<>) (char '\n')
1626           (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
1627
1628 pprInstr (FSQRT size reg1 reg2)     = pprSizeRegReg SLIT("fsqrt") size reg1 reg2
1629 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fsub") size reg1 reg2 reg3
1630 pprInstr (FxTOy size1 size2 reg1 reg2)
1631   = hcat [
1632         ptext SLIT("\tf"),
1633         ptext
1634         (case size1 of
1635             W  -> SLIT("ito")
1636             F  -> SLIT("sto")
1637             DF -> SLIT("dto")),
1638         ptext
1639         (case size2 of
1640             W  -> SLIT("i\t")
1641             F  -> SLIT("s\t")
1642             DF -> SLIT("d\t")),
1643         pprReg reg1, comma, pprReg reg2
1644     ]
1645
1646
1647 pprInstr (BI cond b lab)
1648   = hcat [
1649         ptext SLIT("\tb"), pprCond cond,
1650         if b then pp_comma_a else empty,
1651         char '\t',
1652         pprImm lab
1653     ]
1654
1655 pprInstr (BF cond b lab)
1656   = hcat [
1657         ptext SLIT("\tfb"), pprCond cond,
1658         if b then pp_comma_a else empty,
1659         char '\t',
1660         pprImm lab
1661     ]
1662
1663 pprInstr (JMP dsts addr) = (<>) (ptext SLIT("\tjmp\t")) (pprAddr addr)
1664
1665 pprInstr (CALL (Left imm) n _)
1666   = hcat [ ptext SLIT("\tcall\t"), pprImm imm, comma, int n ]
1667 pprInstr (CALL (Right reg) n _)
1668   = hcat [ ptext SLIT("\tcall\t"), pprReg reg, comma, int n ]
1669 \end{code}
1670
1671 Continue with SPARC-only printing bits and bobs:
1672 \begin{code}
1673 pprRI :: RI -> Doc
1674 pprRI (RIReg r) = pprReg r
1675 pprRI (RIImm r) = pprImm r
1676
1677 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
1678 pprSizeRegReg name size reg1 reg2
1679   = hcat [
1680         char '\t',
1681         ptext name,
1682         (case size of
1683             F  -> ptext SLIT("s\t")
1684             DF -> ptext SLIT("d\t")),
1685         pprReg reg1,
1686         comma,
1687         pprReg reg2
1688     ]
1689
1690 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1691 pprSizeRegRegReg name size reg1 reg2 reg3
1692   = hcat [
1693         char '\t',
1694         ptext name,
1695         (case size of
1696             F  -> ptext SLIT("s\t")
1697             DF -> ptext SLIT("d\t")),
1698         pprReg reg1,
1699         comma,
1700         pprReg reg2,
1701         comma,
1702         pprReg reg3
1703     ]
1704
1705 pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
1706 pprRegRIReg name b reg1 ri reg2
1707   = hcat [
1708         char '\t',
1709         ptext name,
1710         if b then ptext SLIT("cc\t") else char '\t',
1711         pprReg reg1,
1712         comma,
1713         pprRI ri,
1714         comma,
1715         pprReg reg2
1716     ]
1717
1718 pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
1719 pprRIReg name b ri reg1
1720   = hcat [
1721         char '\t',
1722         ptext name,
1723         if b then ptext SLIT("cc\t") else char '\t',
1724         pprRI ri,
1725         comma,
1726         pprReg reg1
1727     ]
1728
1729 pp_ld_lbracket    = ptext SLIT("\tld\t[")
1730 pp_rbracket_comma = text "],"
1731 pp_comma_lbracket = text ",["
1732 pp_comma_a        = text ",a"
1733
1734 #endif {-sparc_TARGET_ARCH-}
1735 \end{code}
1736
1737 \begin{code}
1738 #if __GLASGOW_HASKELL__ >= 504
1739 newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
1740 newFloatArray = newArray_
1741
1742 newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
1743 newDoubleArray = newArray_
1744
1745 castFloatToCharArray :: STUArray s Int Float -> ST s (STUArray s Int Word8)
1746 castFloatToCharArray = castSTUArray
1747
1748 castDoubleToCharArray :: STUArray s Int Double -> ST s (STUArray s Int Word8)
1749 castDoubleToCharArray = castSTUArray
1750
1751 writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
1752 writeFloatArray = writeArray
1753
1754 writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
1755 writeDoubleArray = writeArray
1756
1757 readCharArray :: STUArray s Int Word8 -> Int -> ST s Char
1758 readCharArray arr i = do
1759   w <- readArray arr i
1760   return $! (chr (fromIntegral w))
1761
1762 #else
1763
1764 castFloatToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
1765 castFloatToCharArray = return
1766
1767 castDoubleToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
1768 castDoubleToCharArray = return
1769
1770 #endif
1771
1772 -- floatToBytes and doubleToBytes convert to the host's byte
1773 -- order.  Providing that we're not cross-compiling for a
1774 -- target with the opposite endianness, this should work ok
1775 -- on all targets.
1776
1777 -- ToDo: this stuff is very similar to the shenanigans in PprAbs,
1778 -- could they be merged?
1779
1780 floatToBytes :: Float -> [Int]
1781 floatToBytes f
1782    = runST (do
1783         arr <- newFloatArray ((0::Int),3)
1784         writeFloatArray arr 0 f
1785         arr <- castFloatToCharArray arr
1786         i0 <- readCharArray arr 0
1787         i1 <- readCharArray arr 1
1788         i2 <- readCharArray arr 2
1789         i3 <- readCharArray arr 3
1790         return (map ord [i0,i1,i2,i3])
1791      )
1792
1793 doubleToBytes :: Double -> [Int]
1794 doubleToBytes d
1795    = runST (do
1796         arr <- newDoubleArray ((0::Int),7)
1797         writeDoubleArray arr 0 d
1798         arr <- castDoubleToCharArray arr
1799         i0 <- readCharArray arr 0
1800         i1 <- readCharArray arr 1
1801         i2 <- readCharArray arr 2
1802         i3 <- readCharArray arr 3
1803         i4 <- readCharArray arr 4
1804         i5 <- readCharArray arr 5
1805         i6 <- readCharArray arr 6
1806         i7 <- readCharArray arr 7
1807         return (map ord [i0,i1,i2,i3,i4,i5,i6,i7])
1808      )
1809 \end{code}