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