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