compiler/cmm/PprC.hs

   1 {-# OPTIONS -w #-}
   2 -- The above warning supression flag is a temporary kludge.
   3 -- While working on this module you are encouraged to remove it and fix
   4 -- any warnings in the module. See
   5 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
   6 -- for details
   7
   8 -----------------------------------------------------------------------------
   9 --
  10 -- Pretty-printing of Cmm as C, suitable for feeding gcc
  11 --
  12 -- (c) The University of Glasgow 2004-2006
  13 --
  14 -----------------------------------------------------------------------------
  15
  16 --
  17 -- Print Cmm as real C, for -fvia-C
  18 --
  19 -- See wiki:Commentary/Compiler/Backends/PprC
  20 --
  21 -- This is simpler than the old PprAbsC, because Cmm is "macro-expanded"
  22 -- relative to the old AbstractC, and many oddities/decorations have
  23 -- disappeared from the data type.
  24 --
  25
  26 -- ToDo: save/restore volatile registers around calls.
  27
  28 module PprC (
  29         writeCs,
  30         pprStringInCStyle
  31   ) where
  32
  33 #include "HsVersions.h"
  34
  35 -- Cmm stuff
  36 import BlockId
  37 import OldCmm
  38 import OldPprCmm        ()      -- Instances only
  39 import CLabel
  40 import ForeignCall
  41 import ClosureInfo
  42
  43 -- Utils
  44 import DynFlags
  45 import Unique
  46 import UniqSet
  47 import UniqFM
  48 import FastString
  49 import Outputable
  50 import Constants
  51 import BasicTypes
  52 import CLabel
  53 import Util
  54
  55 -- The rest
  56 import Data.List
  57 import Data.Bits
  58 import Data.Char
  59 import System.IO
  60 import Data.Map (Map)
  61 import qualified Data.Map as Map
  62 import Data.Word
  63
  64 import Data.Array.ST
  65 import Control.Monad.ST
  66
  67 #if x86_64_TARGET_ARCH
  68 import StaticFlags      ( opt_Unregisterised )
  69 #endif
  70
  71 #if defined(alpha_TARGET_ARCH) || defined(mips_TARGET_ARCH) || defined(mipsel_TARGET_ARCH) || defined(arm_TARGET_ARCH)
  72 #define BEWARE_LOAD_STORE_ALIGNMENT
  73 #endif
  74
  75 -- --------------------------------------------------------------------------
  76 -- Top level
  77
  78 pprCs :: DynFlags -> [RawCmm] -> SDoc
  79 pprCs dflags cmms
  80  = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms)
  81  where
  82    split_marker
  83      | dopt Opt_SplitObjs dflags = ptext (sLit "__STG_SPLIT_MARKER")
  84      | otherwise                 = empty
  85
  86 writeCs :: DynFlags -> Handle -> [RawCmm] -> IO ()
  87 writeCs dflags handle cmms
  88   = printForC handle (pprCs dflags cmms)
  89
  90 -- --------------------------------------------------------------------------
  91 -- Now do some real work
  92 --
  93 -- for fun, we could call cmmToCmm over the tops...
  94 --
  95
  96 pprC :: RawCmm -> SDoc
  97 pprC (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops
  98
  99 --
 100 -- top level procs
 101 --
 102 pprTop :: RawCmmTop -> SDoc
 103 pprTop (CmmProc info clbl (ListGraph blocks)) =
 104     (if not (null info)
 105         then pprDataExterns info $$
 106              pprWordArray (entryLblToInfoLbl clbl) info
 107         else empty) $$
 108     (vcat [
 109            blankLine,
 110            extern_decls,
 111            (if (externallyVisibleCLabel clbl)
 112                     then mkFN_ else mkIF_) (pprCLabel clbl) <+> lbrace,
 113            nest 8 temp_decls,
 114            nest 8 mkFB_,
 115            case blocks of
 116                [] -> empty
 117                -- the first block doesn't get a label:
 118                (BasicBlock _ stmts : rest) ->
 119                     nest 8 (vcat (map pprStmt stmts)) $$
 120                        vcat (map pprBBlock rest),
 121            nest 8 mkFE_,
 122            rbrace ]
 123     )
 124   where
 125         (temp_decls, extern_decls) = pprTempAndExternDecls blocks
 126
 127
 128 -- Chunks of static data.
 129
 130 -- We only handle (a) arrays of word-sized things and (b) strings.
 131
 132 pprTop (CmmData _section _ds@[CmmDataLabel lbl, CmmString str]) =
 133   hcat [
 134     pprLocalness lbl, ptext (sLit "char "), pprCLabel lbl,
 135     ptext (sLit "[] = "), pprStringInCStyle str, semi
 136   ]
 137
 138 pprTop (CmmData _section _ds@[CmmDataLabel lbl, CmmUninitialised size]) =
 139   hcat [
 140     pprLocalness lbl, ptext (sLit "char "), pprCLabel lbl,
 141     brackets (int size), semi
 142   ]
 143
 144 pprTop top@(CmmData _section (CmmDataLabel lbl : lits)) =
 145   pprDataExterns lits $$
 146   pprWordArray lbl lits
 147
 148 -- Floating info table for safe a foreign call.
 149 pprTop top@(CmmData _section d@(_ : _))
 150   | CmmDataLabel lbl : lits <- reverse d =
 151   let lits' = reverse lits
 152   in pprDataExterns lits' $$
 153      pprWordArray lbl lits'
 154
 155 -- these shouldn't appear?
 156 pprTop (CmmData _ _) = panic "PprC.pprTop: can't handle this data"
 157
 158 -- --------------------------------------------------------------------------
 159 -- BasicBlocks are self-contained entities: they always end in a jump.
 160 --
 161 -- Like nativeGen/AsmCodeGen, we could probably reorder blocks to turn
 162 -- as many jumps as possible into fall throughs.
 163 --
 164
 165 pprBBlock :: CmmBasicBlock -> SDoc
 166 pprBBlock (BasicBlock lbl stmts) =
 167     if null stmts then
 168         pprTrace "pprC.pprBBlock: curious empty code block for"
 169                         (pprBlockId lbl) empty
 170     else
 171         nest 4 (pprBlockId lbl <> colon) $$
 172         nest 8 (vcat (map pprStmt stmts))
 173
 174 -- --------------------------------------------------------------------------
 175 -- Info tables. Just arrays of words.
 176 -- See codeGen/ClosureInfo, and nativeGen/PprMach
 177
 178 pprWordArray :: CLabel -> [CmmStatic] -> SDoc
 179 pprWordArray lbl ds
 180   = hcat [ pprLocalness lbl, ptext (sLit "StgWord")
 181          , space, pprCLabel lbl, ptext (sLit "[] = {") ]
 182     $$ nest 8 (commafy (pprStatics ds))
 183     $$ ptext (sLit "};")
 184
 185 --
 186 -- has to be static, if it isn't globally visible
 187 --
 188 pprLocalness :: CLabel -> SDoc
 189 pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext (sLit "static ")
 190                  | otherwise = empty
 191
 192 -- --------------------------------------------------------------------------
 193 -- Statements.
 194 --
 195
 196 pprStmt :: CmmStmt -> SDoc
 197
 198 pprStmt stmt = case stmt of
 199     CmmNop       -> empty
 200     CmmComment s -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/")
 201                           -- XXX if the string contains "*/", we need to fix it
 202                           -- XXX we probably want to emit these comments when
 203                           -- some debugging option is on.  They can get quite
 204                           -- large.
 205
 206     CmmAssign dest src -> pprAssign dest src
 207
 208     CmmStore  dest src
 209         | typeWidth rep == W64 && wordWidth /= W64
 210         -> (if isFloatType rep then ptext (sLit "ASSIGN_DBL")
 211                                else ptext (sLit ("ASSIGN_Word64"))) <>
 212            parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi
 213
 214         | otherwise
 215         -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ]
 216         where
 217           rep = cmmExprType src
 218
 219     CmmCall (CmmCallee fn cconv) results args safety ret ->
 220         maybe_proto $$
 221         fnCall
 222         where
 223         cast_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn)
 224
 225         real_fun_proto lbl = char ';' <>
 226                         pprCFunType (pprCLabel lbl) cconv results args <>
 227                         noreturn_attr <> semi
 228
 229         fun_proto lbl = ptext (sLit ";EF_(") <>
 230                          pprCLabel lbl <> char ')' <> semi
 231
 232         noreturn_attr = case ret of
 233                           CmmNeverReturns -> text "__attribute__ ((noreturn))"
 234                           CmmMayReturn    -> empty
 235
 236         -- See wiki:Commentary/Compiler/Backends/PprC#Prototypes
 237         (maybe_proto, fnCall) =
 238             case fn of
 239               CmmLit (CmmLabel lbl)
 240                 | StdCallConv <- cconv ->
 241                     let myCall = pprCall (pprCLabel lbl) cconv results args safety
 242                     in (real_fun_proto lbl, myCall)
 243                         -- stdcall functions must be declared with
 244                         -- a function type, otherwise the C compiler
 245                         -- doesn't add the @n suffix to the label.  We
 246                         -- can't add the @n suffix ourselves, because
 247                         -- it isn't valid C.
 248                 | CmmNeverReturns <- ret ->
 249                     let myCall = pprCall (pprCLabel lbl) cconv results args safety
 250                     in (real_fun_proto lbl, myCall)
 251                 | not (isMathFun lbl) ->
 252                     let myCall = braces (
 253                                      pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
 254                                   $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
 255                                   $$ pprCall (text "ghcFunPtr") cconv results args safety <> semi
 256                                  )
 257                     in (fun_proto lbl, myCall)
 258               _ ->
 259                    (empty {- no proto -},
 260                     pprCall cast_fn cconv results args safety <> semi)
 261                         -- for a dynamic call, no declaration is necessary.
 262
 263     CmmCall (CmmPrim op) results args safety _ret ->
 264         pprCall ppr_fn CCallConv results args safety
 265         where
 266         ppr_fn = pprCallishMachOp_for_C op
 267
 268     CmmBranch ident          -> pprBranch ident
 269     CmmCondBranch expr ident -> pprCondBranch expr ident
 270     CmmJump lbl _params      -> mkJMP_(pprExpr lbl) <> semi
 271     CmmSwitch arg ids        -> pprSwitch arg ids
 272
 273 pprCFunType :: SDoc -> CCallConv -> HintedCmmFormals -> HintedCmmActuals -> SDoc
 274 pprCFunType ppr_fn cconv ress args
 275   = res_type ress <+>
 276     parens (text (ccallConvAttribute cconv) <>  ppr_fn) <>
 277     parens (commafy (map arg_type args))
 278   where
 279         res_type [] = ptext (sLit "void")
 280         res_type [CmmHinted one hint] = machRepHintCType (localRegType one) hint
 281
 282         arg_type (CmmHinted expr hint) = machRepHintCType (cmmExprType expr) hint
 283
 284 -- ---------------------------------------------------------------------
 285 -- unconditional branches
 286 pprBranch :: BlockId -> SDoc
 287 pprBranch ident = ptext (sLit "goto") <+> pprBlockId ident <> semi
 288
 289
 290 -- ---------------------------------------------------------------------
 291 -- conditional branches to local labels
 292 pprCondBranch :: CmmExpr -> BlockId -> SDoc
 293 pprCondBranch expr ident
 294         = hsep [ ptext (sLit "if") , parens(pprExpr expr) ,
 295                         ptext (sLit "goto") , (pprBlockId ident) <> semi ]
 296
 297
 298 -- ---------------------------------------------------------------------
 299 -- a local table branch
 300 --
 301 -- we find the fall-through cases
 302 --
 303 -- N.B. we remove Nothing's from the list of branches, as they are
 304 -- 'undefined'. However, they may be defined one day, so we better
 305 -- document this behaviour.
 306 --
 307 pprSwitch :: CmmExpr -> [ Maybe BlockId ] -> SDoc
 308 pprSwitch e maybe_ids
 309   = let pairs  = [ (ix, ident) | (ix,Just ident) <- zip [0..] maybe_ids ]
 310         pairs2 = [ (map fst as, snd (head as)) | as <- groupBy sndEq pairs ]
 311     in
 312         (hang (ptext (sLit "switch") <+> parens ( pprExpr e ) <+> lbrace)
 313                 4 (vcat ( map caseify pairs2 )))
 314         $$ rbrace
 315
 316   where
 317     sndEq (_,x) (_,y) = x == y
 318
 319     -- fall through case
 320     caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
 321         where
 322         do_fallthrough ix =
 323                  hsep [ ptext (sLit "case") , pprHexVal ix wordWidth <> colon ,
 324                         ptext (sLit "/* fall through */") ]
 325
 326         final_branch ix =
 327                 hsep [ ptext (sLit "case") , pprHexVal ix wordWidth <> colon ,
 328                        ptext (sLit "goto") , (pprBlockId ident) <> semi ]
 329
 330 -- ---------------------------------------------------------------------
 331 -- Expressions.
 332 --
 333
 334 -- C Types: the invariant is that the C expression generated by
 335 --
 336 --      pprExpr e
 337 --
 338 -- has a type in C which is also given by
 339 --
 340 --      machRepCType (cmmExprType e)
 341 --
 342 -- (similar invariants apply to the rest of the pretty printer).
 343
 344 pprExpr :: CmmExpr -> SDoc
 345 pprExpr e = case e of
 346     CmmLit lit -> pprLit lit
 347
 348
 349     CmmLoad e ty -> pprLoad e ty
 350     CmmReg reg      -> pprCastReg reg
 351     CmmRegOff reg 0 -> pprCastReg reg
 352
 353     CmmRegOff reg i
 354         | i >  0    -> pprRegOff (char '+') i
 355         | otherwise -> pprRegOff (char '-') (-i)
 356       where
 357         pprRegOff op i' = pprCastReg reg <> op <> int i'
 358
 359     CmmMachOp mop args -> pprMachOpApp mop args
 360
 361
 362 pprLoad :: CmmExpr -> CmmType -> SDoc
 363 pprLoad e ty
 364   | width == W64, wordWidth /= W64
 365   = (if isFloatType ty then ptext (sLit "PK_DBL")
 366                        else ptext (sLit "PK_Word64"))
 367     <> parens (mkP_ <> pprExpr1 e)
 368
 369   | otherwise
 370   = case e of
 371         CmmReg r | isPtrReg r && width == wordWidth && not (isFloatType ty)
 372                  -> char '*' <> pprAsPtrReg r
 373
 374         CmmRegOff r 0 | isPtrReg r && width == wordWidth && not (isFloatType ty)
 375                       -> char '*' <> pprAsPtrReg r
 376
 377         CmmRegOff r off | isPtrReg r && width == wordWidth
 378                         , off `rem` wORD_SIZE == 0 && not (isFloatType ty)
 379         -- ToDo: check that the offset is a word multiple?
 380         --       (For tagging to work, I had to avoid unaligned loads. --ARY)
 381                         -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift))
 382
 383         _other -> cLoad e ty
 384   where
 385     width = typeWidth ty
 386
 387 pprExpr1 :: CmmExpr -> SDoc
 388 pprExpr1 (CmmLit lit)     = pprLit1 lit
 389 pprExpr1 e@(CmmReg _reg)  = pprExpr e
 390 pprExpr1 other            = parens (pprExpr other)
 391
 392 -- --------------------------------------------------------------------------
 393 -- MachOp applications
 394
 395 pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc
 396
 397 pprMachOpApp op args
 398   | isMulMayOfloOp op
 399   = ptext (sLit "mulIntMayOflo") <> parens (commafy (map pprExpr args))
 400   where isMulMayOfloOp (MO_U_MulMayOflo _) = True
 401         isMulMayOfloOp (MO_S_MulMayOflo _) = True
 402         isMulMayOfloOp _ = False
 403
 404 pprMachOpApp mop args
 405   | Just ty <- machOpNeedsCast mop
 406   = ty <> parens (pprMachOpApp' mop args)
 407   | otherwise
 408   = pprMachOpApp' mop args
 409
 410 -- Comparisons in C have type 'int', but we want type W_ (this is what
 411 -- resultRepOfMachOp says).  The other C operations inherit their type
 412 -- from their operands, so no casting is required.
 413 machOpNeedsCast :: MachOp -> Maybe SDoc
 414 machOpNeedsCast mop
 415   | isComparisonMachOp mop = Just mkW_
 416   | otherwise              = Nothing
 417
 418 pprMachOpApp' mop args
 419  = case args of
 420     -- dyadic
 421     [x,y] -> pprArg x <+> pprMachOp_for_C mop <+> pprArg y
 422
 423     -- unary
 424     [x]   -> pprMachOp_for_C mop <> parens (pprArg x)
 425
 426     _     -> panic "PprC.pprMachOp : machop with wrong number of args"
 427
 428   where
 429         -- Cast needed for signed integer ops
 430     pprArg e | signedOp    mop = cCast (machRep_S_CType (typeWidth (cmmExprType e))) e
 431              | needsFCasts mop = cCast (machRep_F_CType (typeWidth (cmmExprType e))) e
 432              | otherwise    = pprExpr1 e
 433     needsFCasts (MO_F_Eq _)   = False
 434     needsFCasts (MO_F_Ne _)   = False
 435     needsFCasts (MO_F_Neg _)  = True
 436     needsFCasts (MO_F_Quot _) = True
 437     needsFCasts mop  = floatComparison mop
 438
 439 -- --------------------------------------------------------------------------
 440 -- Literals
 441
 442 pprLit :: CmmLit -> SDoc
 443 pprLit lit = case lit of
 444     CmmInt i rep      -> pprHexVal i rep
 445
 446     CmmFloat f w       -> parens (machRep_F_CType w) <> str
 447         where d = fromRational f :: Double
 448               str | isInfinite d && d < 0 = ptext (sLit "-INFINITY")
 449                   | isInfinite d          = ptext (sLit "INFINITY")
 450                   | isNaN d               = ptext (sLit "NAN")
 451                   | otherwise             = text (show d)
 452                 -- these constants come from <math.h>
 453                 -- see #1861
 454
 455     CmmBlock bid       -> mkW_ <> pprCLabelAddr (infoTblLbl bid)
 456     CmmHighStackMark   -> panic "PprC printing high stack mark"
 457     CmmLabel clbl      -> mkW_ <> pprCLabelAddr clbl
 458     CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i
 459     CmmLabelDiffOff clbl1 clbl2 i
 460         -- WARNING:
 461         --  * the lit must occur in the info table clbl2
 462         --  * clbl1 must be an SRT, a slow entry point or a large bitmap
 463         -- The Mangler is expected to convert any reference to an SRT,
 464         -- a slow entry point or a large bitmap
 465         -- from an info table to an offset.
 466         -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i
 467
 468 pprCLabelAddr lbl = char '&' <> pprCLabel lbl
 469
 470 pprLit1 :: CmmLit -> SDoc
 471 pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)
 472 pprLit1 lit@(CmmLabelDiffOff _ _ _) = parens (pprLit lit)
 473 pprLit1 lit@(CmmFloat _ _)    = parens (pprLit lit)
 474 pprLit1 other = pprLit other
 475
 476 -- ---------------------------------------------------------------------------
 477 -- Static data
 478
 479 pprStatics :: [CmmStatic] -> [SDoc]
 480 pprStatics [] = []
 481 pprStatics (CmmStaticLit (CmmFloat f W32) : rest)
 482   -- floats are padded to a word, see #1852
 483   | wORD_SIZE == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest
 484   = pprLit1 (floatToWord f) : pprStatics rest'
 485   | wORD_SIZE == 4
 486   = pprLit1 (floatToWord f) : pprStatics rest
 487   | otherwise
 488   = pprPanic "pprStatics: float" (vcat (map (\(CmmStaticLit l) -> ppr (cmmLitType l)) rest))
 489 pprStatics (CmmStaticLit (CmmFloat f W64) : rest)
 490   = map pprLit1 (doubleToWords f) ++ pprStatics rest
 491 pprStatics (CmmStaticLit (CmmInt i W64) : rest)
 492   | wordWidth == W32
 493 #ifdef WORDS_BIGENDIAN
 494   = pprStatics (CmmStaticLit (CmmInt q W32) :
 495                 CmmStaticLit (CmmInt r W32) : rest)
 496 #else
 497   = pprStatics (CmmStaticLit (CmmInt r W32) :
 498                 CmmStaticLit (CmmInt q W32) : rest)
 499 #endif
 500   where r = i .&. 0xffffffff
 501         q = i `shiftR` 32
 502 pprStatics (CmmStaticLit (CmmInt i w) : rest)
 503   | w /= wordWidth
 504   = panic "pprStatics: cannot emit a non-word-sized static literal"
 505 pprStatics (CmmStaticLit lit : rest)
 506   = pprLit1 lit : pprStatics rest
 507 pprStatics (other : rest)
 508   = pprPanic "pprWord" (pprStatic other)
 509
 510 pprStatic :: CmmStatic -> SDoc
 511 pprStatic s = case s of
 512
 513     CmmStaticLit lit   -> nest 4 (pprLit lit)
 514     CmmAlign i         -> nest 4 (ptext (sLit "/* align */") <+> int i)
 515     CmmDataLabel clbl  -> pprCLabel clbl <> colon
 516     CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i))
 517
 518     -- these should be inlined, like the old .hc
 519     CmmString s'       -> nest 4 (mkW_ <> parens(pprStringInCStyle s'))
 520
 521
 522 -- ---------------------------------------------------------------------------
 523 -- Block Ids
 524
 525 pprBlockId :: BlockId -> SDoc
 526 pprBlockId b = char '_' <> ppr (getUnique b)
 527
 528 -- --------------------------------------------------------------------------
 529 -- Print a MachOp in a way suitable for emitting via C.
 530 --
 531
 532 pprMachOp_for_C :: MachOp -> SDoc
 533
 534 pprMachOp_for_C mop = case mop of
 535
 536         -- Integer operations
 537         MO_Add          _ -> char '+'
 538         MO_Sub          _ -> char '-'
 539         MO_Eq           _ -> ptext (sLit "==")
 540         MO_Ne           _ -> ptext (sLit "!=")
 541         MO_Mul          _ -> char '*'
 542
 543         MO_S_Quot       _ -> char '/'
 544         MO_S_Rem        _ -> char '%'
 545         MO_S_Neg        _ -> char '-'
 546
 547         MO_U_Quot       _ -> char '/'
 548         MO_U_Rem        _ -> char '%'
 549
 550         -- & Floating-point operations
 551         MO_F_Add        _ -> char '+'
 552         MO_F_Sub        _ -> char '-'
 553         MO_F_Neg        _ -> char '-'
 554         MO_F_Mul        _ -> char '*'
 555         MO_F_Quot       _ -> char '/'
 556
 557         -- Signed comparisons
 558         MO_S_Ge         _ -> ptext (sLit ">=")
 559         MO_S_Le         _ -> ptext (sLit "<=")
 560         MO_S_Gt         _ -> char '>'
 561         MO_S_Lt         _ -> char '<'
 562
 563         -- & Unsigned comparisons
 564         MO_U_Ge         _ -> ptext (sLit ">=")
 565         MO_U_Le         _ -> ptext (sLit "<=")
 566         MO_U_Gt         _ -> char '>'
 567         MO_U_Lt         _ -> char '<'
 568
 569         -- & Floating-point comparisons
 570         MO_F_Eq         _ -> ptext (sLit "==")
 571         MO_F_Ne         _ -> ptext (sLit "!=")
 572         MO_F_Ge         _ -> ptext (sLit ">=")
 573         MO_F_Le         _ -> ptext (sLit "<=")
 574         MO_F_Gt         _ -> char '>'
 575         MO_F_Lt         _ -> char '<'
 576
 577         -- Bitwise operations.  Not all of these may be supported at all
 578         -- sizes, and only integral MachReps are valid.
 579         MO_And          _ -> char '&'
 580         MO_Or           _ -> char '|'
 581         MO_Xor          _ -> char '^'
 582         MO_Not          _ -> char '~'
 583         MO_Shl          _ -> ptext (sLit "<<")
 584         MO_U_Shr        _ -> ptext (sLit ">>") -- unsigned shift right
 585         MO_S_Shr        _ -> ptext (sLit ">>") -- signed shift right
 586
 587 -- Conversions.  Some of these will be NOPs, but never those that convert
 588 -- between ints and floats.
 589 -- Floating-point conversions use the signed variant.
 590 -- We won't know to generate (void*) casts here, but maybe from
 591 -- context elsewhere
 592
 593 -- noop casts
 594         MO_UU_Conv from to | from == to -> empty
 595         MO_UU_Conv _from to  -> parens (machRep_U_CType to)
 596
 597         MO_SS_Conv from to | from == to -> empty
 598         MO_SS_Conv _from to  -> parens (machRep_S_CType to)
 599
 600         -- TEMPORARY: the old code didn't check this case, so let's leave it out
 601         -- to facilitate comparisons against the old output code.
 602         --MO_FF_Conv from to | from == to -> empty
 603         MO_FF_Conv _from to  -> parens (machRep_F_CType to)
 604
 605         MO_SF_Conv _from to  -> parens (machRep_F_CType to)
 606         MO_FS_Conv _from to  -> parens (machRep_S_CType to)
 607
 608         _ -> pprTrace "offending mop" (ptext $ sLit $ show mop) $
 609              panic "PprC.pprMachOp_for_C: unknown machop"
 610
 611 signedOp :: MachOp -> Bool      -- Argument type(s) are signed ints
 612 signedOp (MO_S_Quot _)   = True
 613 signedOp (MO_S_Rem  _)   = True
 614 signedOp (MO_S_Neg  _)   = True
 615 signedOp (MO_S_Ge   _)   = True
 616 signedOp (MO_S_Le   _)   = True
 617 signedOp (MO_S_Gt   _)   = True
 618 signedOp (MO_S_Lt   _)   = True
 619 signedOp (MO_S_Shr  _)   = True
 620 signedOp (MO_SS_Conv _ _) = True
 621 signedOp (MO_SF_Conv _ _) = True
 622 signedOp _ = False
 623
 624 floatComparison :: MachOp -> Bool  -- comparison between float args
 625 floatComparison (MO_F_Eq   _)    = True
 626 floatComparison (MO_F_Ne   _)    = True
 627 floatComparison (MO_F_Ge   _)    = True
 628 floatComparison (MO_F_Le   _)    = True
 629 floatComparison (MO_F_Gt   _)    = True
 630 floatComparison (MO_F_Lt   _)    = True
 631 floatComparison _ = False
 632
 633 -- ---------------------------------------------------------------------
 634 -- tend to be implemented by foreign calls
 635
 636 pprCallishMachOp_for_C :: CallishMachOp -> SDoc
 637
 638 pprCallishMachOp_for_C mop
 639     = case mop of
 640         MO_F64_Pwr  -> ptext (sLit "pow")
 641         MO_F64_Sin  -> ptext (sLit "sin")
 642         MO_F64_Cos  -> ptext (sLit "cos")
 643         MO_F64_Tan  -> ptext (sLit "tan")
 644         MO_F64_Sinh -> ptext (sLit "sinh")
 645         MO_F64_Cosh -> ptext (sLit "cosh")
 646         MO_F64_Tanh -> ptext (sLit "tanh")
 647         MO_F64_Asin -> ptext (sLit "asin")
 648         MO_F64_Acos -> ptext (sLit "acos")
 649         MO_F64_Atan -> ptext (sLit "atan")
 650         MO_F64_Log  -> ptext (sLit "log")
 651         MO_F64_Exp  -> ptext (sLit "exp")
 652         MO_F64_Sqrt -> ptext (sLit "sqrt")
 653         MO_F32_Pwr  -> ptext (sLit "powf")
 654         MO_F32_Sin  -> ptext (sLit "sinf")
 655         MO_F32_Cos  -> ptext (sLit "cosf")
 656         MO_F32_Tan  -> ptext (sLit "tanf")
 657         MO_F32_Sinh -> ptext (sLit "sinhf")
 658         MO_F32_Cosh -> ptext (sLit "coshf")
 659         MO_F32_Tanh -> ptext (sLit "tanhf")
 660         MO_F32_Asin -> ptext (sLit "asinf")
 661         MO_F32_Acos -> ptext (sLit "acosf")
 662         MO_F32_Atan -> ptext (sLit "atanf")
 663         MO_F32_Log  -> ptext (sLit "logf")
 664         MO_F32_Exp  -> ptext (sLit "expf")
 665         MO_F32_Sqrt -> ptext (sLit "sqrtf")
 666         MO_WriteBarrier -> ptext (sLit "write_barrier")
 667
 668 -- ---------------------------------------------------------------------
 669 -- Useful #defines
 670 --
 671
 672 mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc
 673
 674 mkJMP_ i = ptext (sLit "JMP_") <> parens i
 675 mkFN_  i = ptext (sLit "FN_")  <> parens i -- externally visible function
 676 mkIF_  i = ptext (sLit "IF_")  <> parens i -- locally visible
 677
 678
 679 mkFB_, mkFE_ :: SDoc
 680 mkFB_ = ptext (sLit "FB_") -- function code begin
 681 mkFE_ = ptext (sLit "FE_") -- function code end
 682
 683 -- from includes/Stg.h
 684 --
 685 mkC_,mkW_,mkP_ :: SDoc
 686
 687 mkC_  = ptext (sLit "(C_)")        -- StgChar
 688 mkW_  = ptext (sLit "(W_)")        -- StgWord
 689 mkP_  = ptext (sLit "(P_)")        -- StgWord*
 690
 691 -- ---------------------------------------------------------------------
 692 --
 693 -- Assignments
 694 --
 695 -- Generating assignments is what we're all about, here
 696 --
 697 pprAssign :: CmmReg -> CmmExpr -> SDoc
 698
 699 -- dest is a reg, rhs is a reg
 700 pprAssign r1 (CmmReg r2)
 701    | isPtrReg r1 && isPtrReg r2
 702    = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ]
 703
 704 -- dest is a reg, rhs is a CmmRegOff
 705 pprAssign r1 (CmmRegOff r2 off)
 706    | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE == 0)
 707    = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]
 708   where
 709         off1 = off `shiftR` wordShift
 710
 711         (op,off') | off >= 0  = (char '+', off1)
 712                   | otherwise = (char '-', -off1)
 713
 714 -- dest is a reg, rhs is anything.
 715 -- We can't cast the lvalue, so we have to cast the rhs if necessary.  Casting
 716 -- the lvalue elicits a warning from new GCC versions (3.4+).
 717 pprAssign r1 r2
 718   | isFixedPtrReg r1             = mkAssign (mkP_ <> pprExpr1 r2)
 719   | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2)
 720   | otherwise                    = mkAssign (pprExpr r2)
 721     where mkAssign x = if r1 == CmmGlobal BaseReg
 722                        then ptext (sLit "ASSIGN_BaseReg") <> parens x <> semi
 723                        else pprReg r1 <> ptext (sLit " = ") <> x <> semi
 724
 725 -- ---------------------------------------------------------------------
 726 -- Registers
 727
 728 pprCastReg reg
 729    | isStrangeTypeReg reg = mkW_ <> pprReg reg
 730    | otherwise            = pprReg reg
 731
 732 -- True if (pprReg reg) will give an expression with type StgPtr.  We
 733 -- need to take care with pointer arithmetic on registers with type
 734 -- StgPtr.
 735 isFixedPtrReg :: CmmReg -> Bool
 736 isFixedPtrReg (CmmLocal _) = False
 737 isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r
 738
 739 -- True if (pprAsPtrReg reg) will give an expression with type StgPtr
 740 -- JD: THIS IS HORRIBLE AND SHOULD BE RENAMED, AT THE VERY LEAST.
 741 -- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT;
 742 -- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY.
 743 isPtrReg :: CmmReg -> Bool
 744 isPtrReg (CmmLocal _)               = False
 745 isPtrReg (CmmGlobal (VanillaReg n VGcPtr)) = True -- if we print via pprAsPtrReg
 746 isPtrReg (CmmGlobal (VanillaReg n VNonGcPtr)) = False --if we print via pprAsPtrReg
 747 isPtrReg (CmmGlobal reg)            = isFixedPtrGlobalReg reg
 748
 749 -- True if this global reg has type StgPtr
 750 isFixedPtrGlobalReg :: GlobalReg -> Bool
 751 isFixedPtrGlobalReg Sp          = True
 752 isFixedPtrGlobalReg Hp          = True
 753 isFixedPtrGlobalReg HpLim       = True
 754 isFixedPtrGlobalReg SpLim       = True
 755 isFixedPtrGlobalReg _           = False
 756
 757 -- True if in C this register doesn't have the type given by
 758 -- (machRepCType (cmmRegType reg)), so it has to be cast.
 759 isStrangeTypeReg :: CmmReg -> Bool
 760 isStrangeTypeReg (CmmLocal _)   = False
 761 isStrangeTypeReg (CmmGlobal g)  = isStrangeTypeGlobal g
 762
 763 isStrangeTypeGlobal :: GlobalReg -> Bool
 764 isStrangeTypeGlobal CurrentTSO          = True
 765 isStrangeTypeGlobal CurrentNursery      = True
 766 isStrangeTypeGlobal BaseReg             = True
 767 isStrangeTypeGlobal r                   = isFixedPtrGlobalReg r
 768
 769 strangeRegType :: CmmReg -> Maybe SDoc
 770 strangeRegType (CmmGlobal CurrentTSO) = Just (ptext (sLit "struct StgTSO_ *"))
 771 strangeRegType (CmmGlobal CurrentNursery) = Just (ptext (sLit "struct bdescr_ *"))
 772 strangeRegType (CmmGlobal BaseReg) = Just (ptext (sLit "struct StgRegTable_ *"))
 773 strangeRegType _ = Nothing
 774
 775 -- pprReg just prints the register name.
 776 --
 777 pprReg :: CmmReg -> SDoc
 778 pprReg r = case r of
 779         CmmLocal  local  -> pprLocalReg local
 780         CmmGlobal global -> pprGlobalReg global
 781
 782 pprAsPtrReg :: CmmReg -> SDoc
 783 pprAsPtrReg (CmmGlobal (VanillaReg n gcp))
 784   = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> ptext (sLit ".p")
 785 pprAsPtrReg other_reg = pprReg other_reg
 786
 787 pprGlobalReg :: GlobalReg -> SDoc
 788 pprGlobalReg gr = case gr of
 789     VanillaReg n _ -> char 'R' <> int n  <> ptext (sLit ".w")
 790         -- pprGlobalReg prints a VanillaReg as a .w regardless
 791         -- Example:     R1.w = R1.w & (-0x8UL);
 792         --              JMP_(*R1.p);
 793     FloatReg   n   -> char 'F' <> int n
 794     DoubleReg  n   -> char 'D' <> int n
 795     LongReg    n   -> char 'L' <> int n
 796     Sp             -> ptext (sLit "Sp")
 797     SpLim          -> ptext (sLit "SpLim")
 798     Hp             -> ptext (sLit "Hp")
 799     HpLim          -> ptext (sLit "HpLim")
 800     CurrentTSO     -> ptext (sLit "CurrentTSO")
 801     CurrentNursery -> ptext (sLit "CurrentNursery")
 802     HpAlloc        -> ptext (sLit "HpAlloc")
 803     BaseReg        -> ptext (sLit "BaseReg")
 804     EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info")
 805     GCEnter1       -> ptext (sLit "stg_gc_enter_1")
 806     GCFun          -> ptext (sLit "stg_gc_fun")
 807
 808 pprLocalReg :: LocalReg -> SDoc
 809 pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq
 810
 811 -- -----------------------------------------------------------------------------
 812 -- Foreign Calls
 813
 814 pprCall :: SDoc -> CCallConv -> HintedCmmFormals -> HintedCmmActuals -> CmmSafety
 815         -> SDoc
 816
 817 pprCall ppr_fn cconv results args _
 818   | not (is_cish cconv)
 819   = panic "pprCall: unknown calling convention"
 820
 821   | otherwise
 822   =
 823 #if x86_64_TARGET_ARCH
 824         -- HACK around gcc optimisations.
 825         -- x86_64 needs a __DISCARD__() here, to create a barrier between
 826         -- putting the arguments into temporaries and passing the arguments
 827         -- to the callee, because the argument expressions may refer to
 828         -- machine registers that are also used for passing arguments in the
 829         -- C calling convention.
 830     (if (not opt_Unregisterised)
 831         then ptext (sLit "__DISCARD__();")
 832         else empty) $$
 833 #endif
 834     ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
 835   where
 836      ppr_assign []           rhs = rhs
 837      ppr_assign [CmmHinted one hint] rhs
 838          = pprLocalReg one <> ptext (sLit " = ")
 839                  <> pprUnHint hint (localRegType one) <> rhs
 840      ppr_assign _other _rhs = panic "pprCall: multiple results"
 841
 842      pprArg (CmmHinted expr AddrHint)
 843         = cCast (ptext (sLit "void *")) expr
 844         -- see comment by machRepHintCType below
 845      pprArg (CmmHinted expr SignedHint)
 846         = cCast (machRep_S_CType $ typeWidth $ cmmExprType expr) expr
 847      pprArg (CmmHinted expr _other)
 848         = pprExpr expr
 849
 850      pprUnHint AddrHint   rep = parens (machRepCType rep)
 851      pprUnHint SignedHint rep = parens (machRepCType rep)
 852      pprUnHint _          _   = empty
 853
 854 pprGlobalRegName :: GlobalReg -> SDoc
 855 pprGlobalRegName gr = case gr of
 856     VanillaReg n _  -> char 'R' <> int n  -- without the .w suffix
 857     _               -> pprGlobalReg gr
 858
 859 -- Currently we only have these two calling conventions, but this might
 860 -- change in the future...
 861 is_cish CCallConv   = True
 862 is_cish StdCallConv = True
 863
 864 -- ---------------------------------------------------------------------
 865 -- Find and print local and external declarations for a list of
 866 -- Cmm statements.
 867 --
 868 pprTempAndExternDecls :: [CmmBasicBlock] -> (SDoc{-temps-}, SDoc{-externs-})
 869 pprTempAndExternDecls stmts
 870   = (vcat (map pprTempDecl (uniqSetToList temps)),
 871      vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls)))
 872   where (temps, lbls) = runTE (mapM_ te_BB stmts)
 873
 874 pprDataExterns :: [CmmStatic] -> SDoc
 875 pprDataExterns statics
 876   = vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls))
 877   where (_, lbls) = runTE (mapM_ te_Static statics)
 878
 879 pprTempDecl :: LocalReg -> SDoc
 880 pprTempDecl l@(LocalReg _ rep)
 881   = hcat [ machRepCType rep, space, pprLocalReg l, semi ]
 882
 883 pprExternDecl :: Bool -> CLabel -> SDoc
 884 pprExternDecl in_srt lbl
 885   -- do not print anything for "known external" things
 886   | not (needsCDecl lbl) = empty
 887   | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz
 888   | otherwise =
 889         hcat [ visibility, label_type lbl,
 890                lparen, pprCLabel lbl, text ");" ]
 891  where
 892   label_type lbl | isCFunctionLabel lbl = ptext (sLit "F_")
 893                  | otherwise            = ptext (sLit "I_")
 894
 895   visibility
 896      | externallyVisibleCLabel lbl = char 'E'
 897      | otherwise                   = char 'I'
 898
 899   -- If the label we want to refer to is a stdcall function (on Windows) then
 900   -- we must generate an appropriate prototype for it, so that the C compiler will
 901   -- add the @n suffix to the label (#2276)
 902   stdcall_decl sz =
 903         ptext (sLit "extern __attribute__((stdcall)) void ") <> pprCLabel lbl
 904         <> parens (commafy (replicate (sz `quot` wORD_SIZE) (machRep_U_CType wordWidth)))
 905         <> semi
 906
 907 type TEState = (UniqSet LocalReg, Map CLabel ())
 908 newtype TE a = TE { unTE :: TEState -> (a, TEState) }
 909
 910 instance Monad TE where
 911    TE m >>= k  = TE $ \s -> case m s of (a, s') -> unTE (k a) s'
 912    return a    = TE $ \s -> (a, s)
 913
 914 te_lbl :: CLabel -> TE ()
 915 te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls))
 916
 917 te_temp :: LocalReg -> TE ()
 918 te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls))
 919
 920 runTE :: TE () -> TEState
 921 runTE (TE m) = snd (m (emptyUniqSet, Map.empty))
 922
 923 te_Static :: CmmStatic -> TE ()
 924 te_Static (CmmStaticLit lit) = te_Lit lit
 925 te_Static _ = return ()
 926
 927 te_BB :: CmmBasicBlock -> TE ()
 928 te_BB (BasicBlock _ ss)         = mapM_ te_Stmt ss
 929
 930 te_Lit :: CmmLit -> TE ()
 931 te_Lit (CmmLabel l) = te_lbl l
 932 te_Lit (CmmLabelOff l _) = te_lbl l
 933 te_Lit (CmmLabelDiffOff l1 l2 _) = te_lbl l1
 934 te_Lit _ = return ()
 935
 936 te_Stmt :: CmmStmt -> TE ()
 937 te_Stmt (CmmAssign r e)         = te_Reg r >> te_Expr e
 938 te_Stmt (CmmStore l r)          = te_Expr l >> te_Expr r
 939 te_Stmt (CmmCall _ rs es _ _)   = mapM_ (te_temp.hintlessCmm) rs >>
 940                                   mapM_ (te_Expr.hintlessCmm) es
 941 te_Stmt (CmmCondBranch e _)     = te_Expr e
 942 te_Stmt (CmmSwitch e _)         = te_Expr e
 943 te_Stmt (CmmJump e _)           = te_Expr e
 944 te_Stmt _                       = return ()
 945
 946 te_Expr :: CmmExpr -> TE ()
 947 te_Expr (CmmLit lit)            = te_Lit lit
 948 te_Expr (CmmLoad e _)           = te_Expr e
 949 te_Expr (CmmReg r)              = te_Reg r
 950 te_Expr (CmmMachOp _ es)        = mapM_ te_Expr es
 951 te_Expr (CmmRegOff r _)         = te_Reg r
 952
 953 te_Reg :: CmmReg -> TE ()
 954 te_Reg (CmmLocal l) = te_temp l
 955 te_Reg _            = return ()
 956
 957
 958 -- ---------------------------------------------------------------------
 959 -- C types for MachReps
 960
 961 cCast :: SDoc -> CmmExpr -> SDoc
 962 cCast ty expr = parens ty <> pprExpr1 expr
 963
 964 cLoad :: CmmExpr -> CmmType -> SDoc
 965 #ifdef BEWARE_LOAD_STORE_ALIGNMENT
 966 cLoad expr rep =
 967     let decl = machRepCType rep <+> ptext (sLit "x") <> semi
 968         struct = ptext (sLit "struct") <+> braces (decl)
 969         packed_attr = ptext (sLit "__attribute__((packed))")
 970         cast = parens (struct <+> packed_attr <> char '*')
 971     in parens (cast <+> pprExpr1 expr) <> ptext (sLit "->x")
 972 #else
 973 cLoad expr rep = char '*' <> parens (cCast (machRepPtrCType rep) expr)
 974 #endif
 975
 976 isCmmWordType :: CmmType -> Bool
 977 -- True of GcPtrReg/NonGcReg of native word size
 978 isCmmWordType ty = not (isFloatType ty)
 979                    && typeWidth ty == wordWidth
 980
 981 -- This is for finding the types of foreign call arguments.  For a pointer
 982 -- argument, we always cast the argument to (void *), to avoid warnings from
 983 -- the C compiler.
 984 machRepHintCType :: CmmType -> ForeignHint -> SDoc
 985 machRepHintCType rep AddrHint    = ptext (sLit "void *")
 986 machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep)
 987 machRepHintCType rep _other     = machRepCType rep
 988
 989 machRepPtrCType :: CmmType -> SDoc
 990 machRepPtrCType r | isCmmWordType r = ptext (sLit "P_")
 991                   | otherwise       = machRepCType r <> char '*'
 992
 993 machRepCType :: CmmType -> SDoc
 994 machRepCType ty | isFloatType ty = machRep_F_CType w
 995                 | otherwise      = machRep_U_CType w
 996                 where
 997                   w = typeWidth ty
 998
 999 machRep_F_CType :: Width -> SDoc
1000 machRep_F_CType W32 = ptext (sLit "StgFloat") -- ToDo: correct?
1001 machRep_F_CType W64 = ptext (sLit "StgDouble")
1002 machRep_F_CType _   = panic "machRep_F_CType"
1003
1004 machRep_U_CType :: Width -> SDoc
1005 machRep_U_CType w | w == wordWidth = ptext (sLit "W_")
1006 machRep_U_CType W8  = ptext (sLit "StgWord8")
1007 machRep_U_CType W16 = ptext (sLit "StgWord16")
1008 machRep_U_CType W32 = ptext (sLit "StgWord32")
1009 machRep_U_CType W64 = ptext (sLit "StgWord64")
1010 machRep_U_CType _   = panic "machRep_U_CType"
1011
1012 machRep_S_CType :: Width -> SDoc
1013 machRep_S_CType w | w == wordWidth = ptext (sLit "I_")
1014 machRep_S_CType W8  = ptext (sLit "StgInt8")
1015 machRep_S_CType W16 = ptext (sLit "StgInt16")
1016 machRep_S_CType W32 = ptext (sLit "StgInt32")
1017 machRep_S_CType W64 = ptext (sLit "StgInt64")
1018 machRep_S_CType _   = panic "machRep_S_CType"
1019
1020
1021 -- ---------------------------------------------------------------------
1022 -- print strings as valid C strings
1023
1024 pprStringInCStyle :: [Word8] -> SDoc
1025 pprStringInCStyle s = doubleQuotes (text (concatMap charToC s))
1026
1027 -- ---------------------------------------------------------------------------
1028 -- Initialising static objects with floating-point numbers.  We can't
1029 -- just emit the floating point number, because C will cast it to an int
1030 -- by rounding it.  We want the actual bit-representation of the float.
1031
1032 -- This is a hack to turn the floating point numbers into ints that we
1033 -- can safely initialise to static locations.
1034
1035 big_doubles
1036   | widthInBytes W64 == 2 * wORD_SIZE  = True
1037   | widthInBytes W64 == wORD_SIZE      = False
1038   | otherwise = panic "big_doubles"
1039
1040 castFloatToIntArray :: STUArray s Int Float -> ST s (STUArray s Int Int)
1041 castFloatToIntArray = castSTUArray
1042
1043 castDoubleToIntArray :: STUArray s Int Double -> ST s (STUArray s Int Int)
1044 castDoubleToIntArray = castSTUArray
1045
1046 -- floats are always 1 word
1047 floatToWord :: Rational -> CmmLit
1048 floatToWord r
1049   = runST (do
1050         arr <- newArray_ ((0::Int),0)
1051         writeArray arr 0 (fromRational r)
1052         arr' <- castFloatToIntArray arr
1053         i <- readArray arr' 0
1054         return (CmmInt (toInteger i) wordWidth)
1055     )
1056
1057 doubleToWords :: Rational -> [CmmLit]
1058 doubleToWords r
1059   | big_doubles                         -- doubles are 2 words
1060   = runST (do
1061         arr <- newArray_ ((0::Int),1)
1062         writeArray arr 0 (fromRational r)
1063         arr' <- castDoubleToIntArray arr
1064         i1 <- readArray arr' 0
1065         i2 <- readArray arr' 1
1066         return [ CmmInt (toInteger i1) wordWidth
1067                , CmmInt (toInteger i2) wordWidth
1068                ]
1069     )
1070   | otherwise                           -- doubles are 1 word
1071   = runST (do
1072         arr <- newArray_ ((0::Int),0)
1073         writeArray arr 0 (fromRational r)
1074         arr' <- castDoubleToIntArray arr
1075         i <- readArray arr' 0
1076         return [ CmmInt (toInteger i) wordWidth ]
1077     )
1078
1079 -- ---------------------------------------------------------------------------
1080 -- Utils
1081
1082 wordShift :: Int
1083 wordShift = widthInLog wordWidth
1084
1085 commafy :: [SDoc] -> SDoc
1086 commafy xs = hsep $ punctuate comma xs
1087
1088 -- Print in C hex format: 0x13fa
1089 pprHexVal :: Integer -> Width -> SDoc
1090 pprHexVal 0 _ = ptext (sLit "0x0")
1091 pprHexVal w rep
1092   | w < 0     = parens (char '-' <> ptext (sLit "0x") <> go (-w) <> repsuffix rep)
1093   | otherwise = ptext (sLit "0x") <> go w <> repsuffix rep
1094   where
1095         -- type suffix for literals:
1096         -- Integer literals are unsigned in Cmm/C.  We explicitly cast to
1097         -- signed values for doing signed operations, but at all other
1098         -- times values are unsigned.  This also helps eliminate occasional
1099         -- warnings about integer overflow from gcc.
1100
1101         -- on 32-bit platforms, add "ULL" to 64-bit literals
1102       repsuffix W64 | wORD_SIZE == 4 = ptext (sLit "ULL")
1103         -- on 64-bit platforms with 32-bit int, add "L" to 64-bit literals
1104       repsuffix W64 | cINT_SIZE == 4 = ptext (sLit "UL")
1105       repsuffix _ = char 'U'
1106
1107       go 0 = empty
1108       go w' = go q <> dig
1109            where
1110              (q,r) = w' `quotRem` 16
1111              dig | r < 10    = char (chr (fromInteger r + ord '0'))
1112                  | otherwise = char (chr (fromInteger r - 10 + ord 'a'))
1113