ghc/compiler/nativeGen/PprMach.hs

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