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