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