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 (text "") $ 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            text "",
 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 -}, cast_fn)
 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 -> HintedCmmFormals -> HintedCmmActuals -> 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_,mkPP_,mkI_,mkA_,mkD_,mkF_,mkB_,mkL_,mkLI_,mkLW_ :: SDoc
 682
 683 mkC_  = ptext (sLit "(C_)")        -- StgChar
 684 mkW_  = ptext (sLit "(W_)")        -- StgWord
 685 mkP_  = ptext (sLit "(P_)")        -- StgWord*
 686 mkPP_ = ptext (sLit "(PP_)")       -- P_*
 687 mkI_  = ptext (sLit "(I_)")        -- StgInt
 688 mkA_  = ptext (sLit "(A_)")        -- StgAddr
 689 mkD_  = ptext (sLit "(D_)")        -- const StgWord*
 690 mkF_  = ptext (sLit "(F_)")        -- StgFunPtr
 691 mkB_  = ptext (sLit "(B_)")        -- StgByteArray
 692 mkL_  = ptext (sLit "(L_)")        -- StgClosurePtr
 693
 694 mkLI_ = ptext (sLit "(LI_)")       -- StgInt64
 695 mkLW_ = ptext (sLit "(LW_)")       -- StgWord64
 696
 697
 698 -- ---------------------------------------------------------------------
 699 --
 700 -- Assignments
 701 --
 702 -- Generating assignments is what we're all about, here
 703 --
 704 pprAssign :: CmmReg -> CmmExpr -> SDoc
 705
 706 -- dest is a reg, rhs is a reg
 707 pprAssign r1 (CmmReg r2)
 708    | isPtrReg r1 && isPtrReg r2
 709    = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ]
 710
 711 -- dest is a reg, rhs is a CmmRegOff
 712 pprAssign r1 (CmmRegOff r2 off)
 713    | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE == 0)
 714    = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]
 715   where
 716         off1 = off `shiftR` wordShift
 717
 718         (op,off') | off >= 0  = (char '+', off1)
 719                   | otherwise = (char '-', -off1)
 720
 721 -- dest is a reg, rhs is anything.
 722 -- We can't cast the lvalue, so we have to cast the rhs if necessary.  Casting
 723 -- the lvalue elicits a warning from new GCC versions (3.4+).
 724 pprAssign r1 r2
 725   | isFixedPtrReg r1             = mkAssign (mkP_ <> pprExpr1 r2)
 726   | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2)
 727   | otherwise                    = mkAssign (pprExpr r2)
 728     where mkAssign x = if r1 == CmmGlobal BaseReg
 729                        then ptext (sLit "ASSIGN_BaseReg") <> parens x <> semi
 730                        else pprReg r1 <> ptext (sLit " = ") <> x <> semi
 731
 732 -- ---------------------------------------------------------------------
 733 -- Registers
 734
 735 pprCastReg reg
 736    | isStrangeTypeReg reg = mkW_ <> pprReg reg
 737    | otherwise            = pprReg reg
 738
 739 -- True if (pprReg reg) will give an expression with type StgPtr.  We
 740 -- need to take care with pointer arithmetic on registers with type
 741 -- StgPtr.
 742 isFixedPtrReg :: CmmReg -> Bool
 743 isFixedPtrReg (CmmLocal _) = False
 744 isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r
 745
 746 -- True if (pprAsPtrReg reg) will give an expression with type StgPtr
 747 -- JD: THIS IS HORRIBLE AND SHOULD BE RENAMED, AT THE VERY LEAST.
 748 -- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT;
 749 -- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY.
 750 isPtrReg :: CmmReg -> Bool
 751 isPtrReg (CmmLocal _)               = False
 752 isPtrReg (CmmGlobal (VanillaReg n VGcPtr)) = True -- if we print via pprAsPtrReg
 753 isPtrReg (CmmGlobal (VanillaReg n VNonGcPtr)) = False --if we print via pprAsPtrReg
 754 isPtrReg (CmmGlobal reg)            = isFixedPtrGlobalReg reg
 755
 756 -- True if this global reg has type StgPtr
 757 isFixedPtrGlobalReg :: GlobalReg -> Bool
 758 isFixedPtrGlobalReg Sp          = True
 759 isFixedPtrGlobalReg Hp          = True
 760 isFixedPtrGlobalReg HpLim       = True
 761 isFixedPtrGlobalReg SpLim       = True
 762 isFixedPtrGlobalReg _           = False
 763
 764 -- True if in C this register doesn't have the type given by
 765 -- (machRepCType (cmmRegType reg)), so it has to be cast.
 766 isStrangeTypeReg :: CmmReg -> Bool
 767 isStrangeTypeReg (CmmLocal _)   = False
 768 isStrangeTypeReg (CmmGlobal g)  = isStrangeTypeGlobal g
 769
 770 isStrangeTypeGlobal :: GlobalReg -> Bool
 771 isStrangeTypeGlobal CurrentTSO          = True
 772 isStrangeTypeGlobal CurrentNursery      = True
 773 isStrangeTypeGlobal BaseReg             = True
 774 isStrangeTypeGlobal r                   = isFixedPtrGlobalReg r
 775
 776 strangeRegType :: CmmReg -> Maybe SDoc
 777 strangeRegType (CmmGlobal CurrentTSO) = Just (ptext (sLit "struct StgTSO_ *"))
 778 strangeRegType (CmmGlobal CurrentNursery) = Just (ptext (sLit "struct bdescr_ *"))
 779 strangeRegType (CmmGlobal BaseReg) = Just (ptext (sLit "struct StgRegTable_ *"))
 780 strangeRegType _ = Nothing
 781
 782 -- pprReg just prints the register name.
 783 --
 784 pprReg :: CmmReg -> SDoc
 785 pprReg r = case r of
 786         CmmLocal  local  -> pprLocalReg local
 787         CmmGlobal global -> pprGlobalReg global
 788
 789 pprAsPtrReg :: CmmReg -> SDoc
 790 pprAsPtrReg (CmmGlobal (VanillaReg n gcp))
 791   = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> ptext (sLit ".p")
 792 pprAsPtrReg other_reg = pprReg other_reg
 793
 794 pprGlobalReg :: GlobalReg -> SDoc
 795 pprGlobalReg gr = case gr of
 796     VanillaReg n _ -> char 'R' <> int n  <> ptext (sLit ".w")
 797         -- pprGlobalReg prints a VanillaReg as a .w regardless
 798         -- Example:     R1.w = R1.w & (-0x8UL);
 799         --              JMP_(*R1.p);
 800     FloatReg   n   -> char 'F' <> int n
 801     DoubleReg  n   -> char 'D' <> int n
 802     LongReg    n   -> char 'L' <> int n
 803     Sp             -> ptext (sLit "Sp")
 804     SpLim          -> ptext (sLit "SpLim")
 805     Hp             -> ptext (sLit "Hp")
 806     HpLim          -> ptext (sLit "HpLim")
 807     CurrentTSO     -> ptext (sLit "CurrentTSO")
 808     CurrentNursery -> ptext (sLit "CurrentNursery")
 809     HpAlloc        -> ptext (sLit "HpAlloc")
 810     BaseReg        -> ptext (sLit "BaseReg")
 811     EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info")
 812     GCEnter1       -> ptext (sLit "stg_gc_enter_1")
 813     GCFun          -> ptext (sLit "stg_gc_fun")
 814
 815 pprLocalReg :: LocalReg -> SDoc
 816 pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq
 817
 818 -- -----------------------------------------------------------------------------
 819 -- Foreign Calls
 820
 821 pprCall :: SDoc -> CCallConv -> HintedCmmFormals -> HintedCmmActuals -> CmmSafety
 822         -> SDoc
 823
 824 pprCall ppr_fn cconv results args _
 825   | not (is_cish cconv)
 826   = panic "pprCall: unknown calling convention"
 827
 828   | otherwise
 829   =
 830 #if x86_64_TARGET_ARCH
 831         -- HACK around gcc optimisations.
 832         -- x86_64 needs a __DISCARD__() here, to create a barrier between
 833         -- putting the arguments into temporaries and passing the arguments
 834         -- to the callee, because the argument expressions may refer to
 835         -- machine registers that are also used for passing arguments in the
 836         -- C calling convention.
 837     (if (not opt_Unregisterised)
 838         then ptext (sLit "__DISCARD__();")
 839         else empty) $$
 840 #endif
 841     ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
 842   where
 843      ppr_assign []           rhs = rhs
 844      ppr_assign [CmmHinted one hint] rhs
 845          = pprLocalReg one <> ptext (sLit " = ")
 846                  <> pprUnHint hint (localRegType one) <> rhs
 847      ppr_assign _other _rhs = panic "pprCall: multiple results"
 848
 849      pprArg (CmmHinted expr AddrHint)
 850         = cCast (ptext (sLit "void *")) expr
 851         -- see comment by machRepHintCType below
 852      pprArg (CmmHinted expr SignedHint)
 853         = cCast (machRep_S_CType $ typeWidth $ cmmExprType expr) expr
 854      pprArg (CmmHinted expr _other)
 855         = pprExpr expr
 856
 857      pprUnHint AddrHint   rep = parens (machRepCType rep)
 858      pprUnHint SignedHint rep = parens (machRepCType rep)
 859      pprUnHint _          _   = empty
 860
 861 pprGlobalRegName :: GlobalReg -> SDoc
 862 pprGlobalRegName gr = case gr of
 863     VanillaReg n _  -> char 'R' <> int n  -- without the .w suffix
 864     _               -> pprGlobalReg gr
 865
 866 -- Currently we only have these two calling conventions, but this might
 867 -- change in the future...
 868 is_cish CCallConv   = True
 869 is_cish StdCallConv = True
 870
 871 -- ---------------------------------------------------------------------
 872 -- Find and print local and external declarations for a list of
 873 -- Cmm statements.
 874 --
 875 pprTempAndExternDecls :: [CmmBasicBlock] -> (SDoc{-temps-}, SDoc{-externs-})
 876 pprTempAndExternDecls stmts
 877   = (vcat (map pprTempDecl (uniqSetToList temps)),
 878      vcat (map (pprExternDecl False{-ToDo-}) (keysFM lbls)))
 879   where (temps, lbls) = runTE (mapM_ te_BB stmts)
 880
 881 pprDataExterns :: [CmmStatic] -> SDoc
 882 pprDataExterns statics
 883   = vcat (map (pprExternDecl False{-ToDo-}) (keysFM lbls))
 884   where (_, lbls) = runTE (mapM_ te_Static statics)
 885
 886 pprTempDecl :: LocalReg -> SDoc
 887 pprTempDecl l@(LocalReg _ rep)
 888   = hcat [ machRepCType rep, space, pprLocalReg l, semi ]
 889
 890 pprExternDecl :: Bool -> CLabel -> SDoc
 891 pprExternDecl in_srt lbl
 892   -- do not print anything for "known external" things
 893   | not (needsCDecl lbl) = empty
 894   | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz
 895   | otherwise =
 896         hcat [ visibility, label_type lbl,
 897                lparen, pprCLabel lbl, text ");" ]
 898  where
 899   label_type lbl | isCFunctionLabel lbl = ptext (sLit "F_")
 900                  | otherwise            = ptext (sLit "I_")
 901
 902   visibility
 903      | externallyVisibleCLabel lbl = char 'E'
 904      | otherwise                   = char 'I'
 905
 906   -- If the label we want to refer to is a stdcall function (on Windows) then
 907   -- we must generate an appropriate prototype for it, so that the C compiler will
 908   -- add the @n suffix to the label (#2276)
 909   stdcall_decl sz =
 910         ptext (sLit "extern __attribute__((stdcall)) void ") <> pprCLabel lbl
 911         <> parens (commafy (replicate (sz `quot` wORD_SIZE) (machRep_U_CType wordWidth)))
 912         <> semi
 913
 914 type TEState = (UniqSet LocalReg, FiniteMap CLabel ())
 915 newtype TE a = TE { unTE :: TEState -> (a, TEState) }
 916
 917 instance Monad TE where
 918    TE m >>= k  = TE $ \s -> case m s of (a, s') -> unTE (k a) s'
 919    return a    = TE $ \s -> (a, s)
 920
 921 te_lbl :: CLabel -> TE ()
 922 te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, addToFM lbls lbl ()))
 923
 924 te_temp :: LocalReg -> TE ()
 925 te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls))
 926
 927 runTE :: TE () -> TEState
 928 runTE (TE m) = snd (m (emptyUniqSet, emptyFM))
 929
 930 te_Static :: CmmStatic -> TE ()
 931 te_Static (CmmStaticLit lit) = te_Lit lit
 932 te_Static _ = return ()
 933
 934 te_BB :: CmmBasicBlock -> TE ()
 935 te_BB (BasicBlock _ ss)         = mapM_ te_Stmt ss
 936
 937 te_Lit :: CmmLit -> TE ()
 938 te_Lit (CmmLabel l) = te_lbl l
 939 te_Lit (CmmLabelOff l _) = te_lbl l
 940 te_Lit (CmmLabelDiffOff l1 l2 _) = te_lbl l1
 941 te_Lit _ = return ()
 942
 943 te_Stmt :: CmmStmt -> TE ()
 944 te_Stmt (CmmAssign r e)         = te_Reg r >> te_Expr e
 945 te_Stmt (CmmStore l r)          = te_Expr l >> te_Expr r
 946 te_Stmt (CmmCall _ rs es _ _)   = mapM_ (te_temp.hintlessCmm) rs >>
 947                                   mapM_ (te_Expr.hintlessCmm) es
 948 te_Stmt (CmmCondBranch e _)     = te_Expr e
 949 te_Stmt (CmmSwitch e _)         = te_Expr e
 950 te_Stmt (CmmJump e _)           = te_Expr e
 951 te_Stmt _                       = return ()
 952
 953 te_Expr :: CmmExpr -> TE ()
 954 te_Expr (CmmLit lit)            = te_Lit lit
 955 te_Expr (CmmLoad e _)           = te_Expr e
 956 te_Expr (CmmReg r)              = te_Reg r
 957 te_Expr (CmmMachOp _ es)        = mapM_ te_Expr es
 958 te_Expr (CmmRegOff r _)         = te_Reg r
 959
 960 te_Reg :: CmmReg -> TE ()
 961 te_Reg (CmmLocal l) = te_temp l
 962 te_Reg _            = return ()
 963
 964
 965 -- ---------------------------------------------------------------------
 966 -- C types for MachReps
 967
 968 cCast :: SDoc -> CmmExpr -> SDoc
 969 cCast ty expr = parens ty <> pprExpr1 expr
 970
 971 cLoad :: CmmExpr -> CmmType -> SDoc
 972 #ifdef BEWARE_LOAD_STORE_ALIGNMENT
 973 cLoad expr rep =
 974     let decl = machRepCType rep <+> ptext (sLit "x") <> semi
 975         struct = ptext (sLit "struct") <+> braces (decl)
 976         packed_attr = ptext (sLit "__attribute__((packed))")
 977         cast = parens (struct <+> packed_attr <> char '*')
 978     in parens (cast <+> pprExpr1 expr) <> ptext (sLit "->x")
 979 #else
 980 cLoad expr rep = char '*' <> parens (cCast (machRepPtrCType rep) expr)
 981 #endif
 982
 983 isCmmWordType :: CmmType -> Bool
 984 -- True of GcPtrReg/NonGcReg of native word size
 985 isCmmWordType ty = not (isFloatType ty)
 986                    && typeWidth ty == wordWidth
 987
 988 -- This is for finding the types of foreign call arguments.  For a pointer
 989 -- argument, we always cast the argument to (void *), to avoid warnings from
 990 -- the C compiler.
 991 machRepHintCType :: CmmType -> ForeignHint -> SDoc
 992 machRepHintCType rep AddrHint    = ptext (sLit "void *")
 993 machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep)
 994 machRepHintCType rep _other     = machRepCType rep
 995
 996 machRepPtrCType :: CmmType -> SDoc
 997 machRepPtrCType r | isCmmWordType r = ptext (sLit "P_")
 998                   | otherwise       = machRepCType r <> char '*'
 999
1000 machRepCType :: CmmType -> SDoc
1001 machRepCType ty | isFloatType ty = machRep_F_CType w
1002                 | otherwise      = machRep_U_CType w
1003                 where
1004                   w = typeWidth ty
1005
1006 machRep_F_CType :: Width -> SDoc
1007 machRep_F_CType W32 = ptext (sLit "StgFloat") -- ToDo: correct?
1008 machRep_F_CType W64 = ptext (sLit "StgDouble")
1009 machRep_F_CType _   = panic "machRep_F_CType"
1010
1011 machRep_U_CType :: Width -> SDoc
1012 machRep_U_CType w | w == wordWidth = ptext (sLit "W_")
1013 machRep_U_CType W8  = ptext (sLit "StgWord8")
1014 machRep_U_CType W16 = ptext (sLit "StgWord16")
1015 machRep_U_CType W32 = ptext (sLit "StgWord32")
1016 machRep_U_CType W64 = ptext (sLit "StgWord64")
1017 machRep_U_CType _   = panic "machRep_U_CType"
1018
1019 machRep_S_CType :: Width -> SDoc
1020 machRep_S_CType w | w == wordWidth = ptext (sLit "I_")
1021 machRep_S_CType W8  = ptext (sLit "StgInt8")
1022 machRep_S_CType W16 = ptext (sLit "StgInt16")
1023 machRep_S_CType W32 = ptext (sLit "StgInt32")
1024 machRep_S_CType W64 = ptext (sLit "StgInt64")
1025 machRep_S_CType _   = panic "machRep_S_CType"
1026
1027
1028 -- ---------------------------------------------------------------------
1029 -- print strings as valid C strings
1030
1031 pprStringInCStyle :: [Word8] -> SDoc
1032 pprStringInCStyle s = doubleQuotes (text (concatMap charToC s))
1033
1034 charToC :: Word8 -> String
1035 charToC w =
1036   case chr (fromIntegral w) of
1037         '\"' -> "\\\""
1038         '\'' -> "\\\'"
1039         '\\' -> "\\\\"
1040         c | c >= ' ' && c <= '~' -> [c]
1041           | otherwise -> ['\\',
1042                          chr (ord '0' + ord c `div` 64),
1043                          chr (ord '0' + ord c `div` 8 `mod` 8),
1044                          chr (ord '0' + ord c         `mod` 8)]
1045
1046 -- ---------------------------------------------------------------------------
1047 -- Initialising static objects with floating-point numbers.  We can't
1048 -- just emit the floating point number, because C will cast it to an int
1049 -- by rounding it.  We want the actual bit-representation of the float.
1050
1051 -- This is a hack to turn the floating point numbers into ints that we
1052 -- can safely initialise to static locations.
1053
1054 big_doubles
1055   | widthInBytes W64 == 2 * wORD_SIZE  = True
1056   | widthInBytes W64 == wORD_SIZE      = False
1057   | otherwise = panic "big_doubles"
1058
1059 castFloatToIntArray :: STUArray s Int Float -> ST s (STUArray s Int Int)
1060 castFloatToIntArray = castSTUArray
1061
1062 castDoubleToIntArray :: STUArray s Int Double -> ST s (STUArray s Int Int)
1063 castDoubleToIntArray = castSTUArray
1064
1065 -- floats are always 1 word
1066 floatToWord :: Rational -> CmmLit
1067 floatToWord r
1068   = runST (do
1069         arr <- newArray_ ((0::Int),0)
1070         writeArray arr 0 (fromRational r)
1071         arr' <- castFloatToIntArray arr
1072         i <- readArray arr' 0
1073         return (CmmInt (toInteger i) wordWidth)
1074     )
1075
1076 doubleToWords :: Rational -> [CmmLit]
1077 doubleToWords r
1078   | big_doubles                         -- doubles are 2 words
1079   = runST (do
1080         arr <- newArray_ ((0::Int),1)
1081         writeArray arr 0 (fromRational r)
1082         arr' <- castDoubleToIntArray arr
1083         i1 <- readArray arr' 0
1084         i2 <- readArray arr' 1
1085         return [ CmmInt (toInteger i1) wordWidth
1086                , CmmInt (toInteger i2) wordWidth
1087                ]
1088     )
1089   | otherwise                           -- doubles are 1 word
1090   = runST (do
1091         arr <- newArray_ ((0::Int),0)
1092         writeArray arr 0 (fromRational r)
1093         arr' <- castDoubleToIntArray arr
1094         i <- readArray arr' 0
1095         return [ CmmInt (toInteger i) wordWidth ]
1096     )
1097
1098 -- ---------------------------------------------------------------------------
1099 -- Utils
1100
1101 wordShift :: Int
1102 wordShift = widthInLog wordWidth
1103
1104 commafy :: [SDoc] -> SDoc
1105 commafy xs = hsep $ punctuate comma xs
1106
1107 -- Print in C hex format: 0x13fa
1108 pprHexVal :: Integer -> Width -> SDoc
1109 pprHexVal 0 _ = ptext (sLit "0x0")
1110 pprHexVal w rep
1111   | w < 0     = parens (char '-' <> ptext (sLit "0x") <> go (-w) <> repsuffix rep)
1112   | otherwise = ptext (sLit "0x") <> go w <> repsuffix rep
1113   where
1114         -- type suffix for literals:
1115         -- Integer literals are unsigned in Cmm/C.  We explicitly cast to
1116         -- signed values for doing signed operations, but at all other
1117         -- times values are unsigned.  This also helps eliminate occasional
1118         -- warnings about integer overflow from gcc.
1119
1120         -- on 32-bit platforms, add "ULL" to 64-bit literals
1121       repsuffix W64 | wORD_SIZE == 4 = ptext (sLit "ULL")
1122         -- on 64-bit platforms with 32-bit int, add "L" to 64-bit literals
1123       repsuffix W64 | cINT_SIZE == 4 = ptext (sLit "UL")
1124       repsuffix _ = char 'U'
1125
1126       go 0 = empty
1127       go w' = go q <> dig
1128            where
1129              (q,r) = w' `quotRem` 16
1130              dig | r < 10    = char (chr (fromInteger r + ord '0'))
1131                  | otherwise = char (chr (fromInteger r - 10 + ord 'a'))
1132