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