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