PprC.hs 37.6 KB
Newer Older
1 2 3 4 5 6 7
{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details

8 9 10 11
-----------------------------------------------------------------------------
--
-- Pretty-printing of Cmm as C, suitable for feeding gcc
--
Simon Marlow's avatar
Simon Marlow committed
12
-- (c) The University of Glasgow 2004-2006
13 14 15 16 17 18
--
-----------------------------------------------------------------------------

--
-- Print Cmm as real C, for -fvia-C
--
19 20
-- See wiki:Commentary/Compiler/Backends/PprC
--
21 22 23 24 25 26 27 28 29 30 31 32
-- This is simpler than the old PprAbsC, because Cmm is "macro-expanded"
-- relative to the old AbstractC, and many oddities/decorations have
-- disappeared from the data type.
--

-- ToDo: save/restore volatile registers around calls.

module PprC (
        writeCs,
        pprStringInCStyle 
  ) where

33 34
#include "HsVersions.h"

35
-- Cmm stuff
36
import BlockId
37
import Cmm
38
import PprCmm	()	-- Instances only
39 40
import CLabel
import ForeignCall
41
import ClosureInfo
42 43

-- Utils
Simon Marlow's avatar
Simon Marlow committed
44 45
import DynFlags
import Unique
46 47
import UniqSet
import FiniteMap
Simon Marlow's avatar
Simon Marlow committed
48
import UniqFM
49 50 51 52 53
import FastString
import Outputable
import Constants

-- The rest
Simon Marlow's avatar
Simon Marlow committed
54 55 56 57 58
import Data.List
import Data.Bits
import Data.Char
import System.IO
import Data.Word
59 60

import Data.Array.ST
Simon Marlow's avatar
Simon Marlow committed
61
import Control.Monad.ST
62

Simon Marlow's avatar
Simon Marlow committed
63 64 65 66
#if x86_64_TARGET_ARCH
import StaticFlags	( opt_Unregisterised )
#endif

67 68 69 70
#if defined(alpha_TARGET_ARCH) || defined(mips_TARGET_ARCH) || defined(mipsel_TARGET_ARCH) || defined(arm_TARGET_ARCH)
#define BEWARE_LOAD_STORE_ALIGNMENT
#endif

71 72 73
-- --------------------------------------------------------------------------
-- Top level

74
pprCs :: DynFlags -> [RawCmm] -> SDoc
75 76 77 78
pprCs dflags cmms
 = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms)
 where
   split_marker
Ian Lynagh's avatar
Ian Lynagh committed
79
     | dopt Opt_SplitObjs dflags = ptext (sLit "__STG_SPLIT_MARKER")
80 81
     | otherwise     	         = empty

82
writeCs :: DynFlags -> Handle -> [RawCmm] -> IO ()
83
writeCs dflags handle cmms 
84
  = printForC handle (pprCs dflags cmms)
85 86 87 88 89 90 91

-- --------------------------------------------------------------------------
-- Now do some real work
--
-- for fun, we could call cmmToCmm over the tops...
--

92
pprC :: RawCmm -> SDoc
93 94 95 96 97
pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops

--
-- top level procs
-- 
98
pprTop :: RawCmmTop -> SDoc
99
pprTop (CmmProc info clbl _params (ListGraph blocks)) =
100
    (if not (null info)
101 102
        then pprDataExterns info $$
             pprWordArray (entryLblToInfoLbl clbl) info
103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128
        else empty) $$
    (case blocks of
        [] -> empty
         -- the first block doesn't get a label:
        (BasicBlock _ stmts : rest) -> vcat [
	   text "",
	   extern_decls,
           (if (externallyVisibleCLabel clbl)
                    then mkFN_ else mkIF_) (pprCLabel clbl) <+> lbrace,
           nest 8 temp_decls,
           nest 8 mkFB_,
           nest 8 (vcat (map pprStmt stmts)) $$
              vcat (map pprBBlock rest),
           nest 8 mkFE_,
           rbrace ]
    )
  where
	(temp_decls, extern_decls) = pprTempAndExternDecls blocks 


-- Chunks of static data.

-- We only handle (a) arrays of word-sized things and (b) strings.

pprTop (CmmData _section _ds@[CmmDataLabel lbl, CmmString str]) = 
  hcat [
Ian Lynagh's avatar
Ian Lynagh committed
129 130
    pprLocalness lbl, ptext (sLit "char "), pprCLabel lbl,
    ptext (sLit "[] = "), pprStringInCStyle str, semi
131 132 133 134
  ]

pprTop (CmmData _section _ds@[CmmDataLabel lbl, CmmUninitialised size]) = 
  hcat [
Ian Lynagh's avatar
Ian Lynagh committed
135
    pprLocalness lbl, ptext (sLit "char "), pprCLabel lbl,
136 137 138 139 140 141 142
    brackets (int size), semi
  ]

pprTop top@(CmmData _section (CmmDataLabel lbl : lits)) = 
  pprDataExterns lits $$
  pprWordArray lbl lits  

143 144 145
-- Floating info table for safe a foreign call.
pprTop top@(CmmData _section d@(_ : _))
  | CmmDataLabel lbl : lits <- reverse d = 
146 147 148
  let lits' = reverse lits
  in pprDataExterns lits' $$
     pprWordArray lbl lits'
149

150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174
-- these shouldn't appear?
pprTop (CmmData _ _) = panic "PprC.pprTop: can't handle this data"

-- --------------------------------------------------------------------------
-- BasicBlocks are self-contained entities: they always end in a jump.
--
-- Like nativeGen/AsmCodeGen, we could probably reorder blocks to turn
-- as many jumps as possible into fall throughs.
--

pprBBlock :: CmmBasicBlock -> SDoc
pprBBlock (BasicBlock lbl stmts) = 
    if null stmts then
        pprTrace "pprC.pprBBlock: curious empty code block for" 
                        (pprBlockId lbl) empty
    else 
        nest 4 (pprBlockId lbl <> colon) $$
        nest 8 (vcat (map pprStmt stmts))

-- --------------------------------------------------------------------------
-- Info tables. Just arrays of words. 
-- See codeGen/ClosureInfo, and nativeGen/PprMach

pprWordArray :: CLabel -> [CmmStatic] -> SDoc
pprWordArray lbl ds
Ian Lynagh's avatar
Ian Lynagh committed
175 176
  = hcat [ pprLocalness lbl, ptext (sLit "StgWord")
         , space, pprCLabel lbl, ptext (sLit "[] = {") ] 
177
    $$ nest 8 (commafy (pprStatics ds))
Ian Lynagh's avatar
Ian Lynagh committed
178
    $$ ptext (sLit "};")
179 180 181 182 183

--
-- has to be static, if it isn't globally visible
--
pprLocalness :: CLabel -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
184
pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext (sLit "static ")
185 186 187 188 189 190 191 192 193 194
                 | otherwise = empty

-- --------------------------------------------------------------------------
-- Statements.
--

pprStmt :: CmmStmt -> SDoc

pprStmt stmt = case stmt of
    CmmNop       -> empty
Ian Lynagh's avatar
Ian Lynagh committed
195
    CmmComment s -> (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/")
196 197 198 199

    CmmAssign dest src -> pprAssign dest src

    CmmStore  dest src
200 201 202 203
 	| typeWidth rep == W64 && wordWidth /= W64
 	-> (if isFloatType rep then ptext (sLit "ASSIGN_DBL")
 			       else ptext (sLit ("ASSIGN_Word64"))) <> 
 	   parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi
204

205 206 207
 	| otherwise
	-> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ]
	where
208
	  rep = cmmExprType src
209

210
    CmmCall (CmmCallee fn cconv) results args safety ret ->
211
        maybe_proto $$
212
	pprCall ppr_fn cconv results args safety
213
	where
214 215 216 217 218 219 220 221 222 223 224 225
        cast_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn)

        real_fun_proto lbl = char ';' <> 
                        pprCFunType (pprCLabel lbl) cconv results args <> 
                        noreturn_attr <> semi

        data_proto lbl = ptext (sLit ";EI_(") <> 
                         pprCLabel lbl <> char ')' <> semi

        noreturn_attr = case ret of
                          CmmNeverReturns -> text "__attribute__ ((noreturn))"
                          CmmMayReturn    -> empty
226

227
        -- See wiki:Commentary/Compiler/Backends/PprC#Prototypes
228
    	(maybe_proto, ppr_fn) = 
229
            case fn of
230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245
	      CmmLit (CmmLabel lbl) 
                | StdCallConv <- cconv -> (real_fun_proto lbl, pprCLabel lbl)
                        -- stdcall functions must be declared with
                        -- a function type, otherwise the C compiler
                        -- doesn't add the @n suffix to the label.  We
                        -- can't add the @n suffix ourselves, because
                        -- it isn't valid C.
                | CmmNeverReturns <- ret -> (real_fun_proto lbl, pprCLabel lbl)
                | not (isMathFun lbl) -> (data_proto lbl, cast_fn)
                        -- we declare all other called functions as
                        -- data labels, and then cast them to the
                        -- right type when calling.  This is because
                        -- the label might already have a declaration
                        -- as a data label in the same file,
                        -- e.g. Foreign.Marshal.Alloc declares 'free'
                        -- as both a data label and a function label.
246
	      _ -> 
247
                   (empty {- no proto -}, cast_fn)
248
			-- for a dynamic call, no declaration is necessary.
249

250
    CmmCall (CmmPrim op) results args safety _ret ->
251
	pprCall ppr_fn CCallConv results args safety
252 253 254 255 256 257 258 259
	where
    	ppr_fn = pprCallishMachOp_for_C op

    CmmBranch ident          -> pprBranch ident
    CmmCondBranch expr ident -> pprCondBranch expr ident
    CmmJump lbl _params      -> mkJMP_(pprExpr lbl) <> semi
    CmmSwitch arg ids        -> pprSwitch arg ids

260
pprCFunType :: SDoc -> CCallConv -> HintedCmmFormals -> HintedCmmActuals -> SDoc
261 262 263 264
pprCFunType ppr_fn cconv ress args
  = res_type ress <+>
    parens (text (ccallConvAttribute cconv) <>  ppr_fn) <>
    parens (commafy (map arg_type args))
265
  where
Ian Lynagh's avatar
Ian Lynagh committed
266
	res_type [] = ptext (sLit "void")
267
	res_type [CmmHinted one hint] = machRepHintCType (localRegType one) hint
268

269
	arg_type (CmmHinted expr hint) = machRepHintCType (cmmExprType expr) hint
270 271 272 273

-- ---------------------------------------------------------------------
-- unconditional branches
pprBranch :: BlockId -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
274
pprBranch ident = ptext (sLit "goto") <+> pprBlockId ident <> semi
275 276 277 278 279 280


-- ---------------------------------------------------------------------
-- conditional branches to local labels
pprCondBranch :: CmmExpr -> BlockId -> SDoc
pprCondBranch expr ident 
Ian Lynagh's avatar
Ian Lynagh committed
281 282
        = hsep [ ptext (sLit "if") , parens(pprExpr expr) ,
                        ptext (sLit "goto") , (pprBlockId ident) <> semi ]
283 284 285 286 287 288 289 290 291 292 293 294 295


-- ---------------------------------------------------------------------
-- a local table branch
--
-- we find the fall-through cases
--
-- N.B. we remove Nothing's from the list of branches, as they are
-- 'undefined'. However, they may be defined one day, so we better
-- document this behaviour.
--
pprSwitch :: CmmExpr -> [ Maybe BlockId ] -> SDoc
pprSwitch e maybe_ids 
296 297
  = let pairs  = [ (ix, ident) | (ix,Just ident) <- zip [0..] maybe_ids ]
	pairs2 = [ (map fst as, snd (head as)) | as <- groupBy sndEq pairs ]
298
    in 
Ian Lynagh's avatar
Ian Lynagh committed
299
        (hang (ptext (sLit "switch") <+> parens ( pprExpr e ) <+> lbrace)
300
                4 (vcat ( map caseify pairs2 )))
301 302 303
        $$ rbrace

  where
304
    sndEq (_,x) (_,y) = x == y
305

306 307 308 309
    -- fall through case
    caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
	where 
	do_fallthrough ix =
310
                 hsep [ ptext (sLit "case") , pprHexVal ix wordWidth <> colon ,
Ian Lynagh's avatar
Ian Lynagh committed
311
                        ptext (sLit "/* fall through */") ]
312 313

	final_branch ix = 
314
	        hsep [ ptext (sLit "case") , pprHexVal ix wordWidth <> colon ,
Ian Lynagh's avatar
Ian Lynagh committed
315
                       ptext (sLit "goto") , (pprBlockId ident) <> semi ]
316 317 318 319 320 321 322 323 324 325 326

-- ---------------------------------------------------------------------
-- Expressions.
--

-- C Types: the invariant is that the C expression generated by
--
--	pprExpr e
--
-- has a type in C which is also given by
--
327
--	machRepCType (cmmExprType e)
328 329 330 331 332 333 334 335
--
-- (similar invariants apply to the rest of the pretty printer).

pprExpr :: CmmExpr -> SDoc
pprExpr e = case e of
    CmmLit lit -> pprLit lit


336
    CmmLoad e ty -> pprLoad e ty
337 338 339 340 341 342 343 344 345 346 347
    CmmReg reg      -> pprCastReg reg
    CmmRegOff reg 0 -> pprCastReg reg

    CmmRegOff reg i
	| i >  0    -> pprRegOff (char '+') i
	| otherwise -> pprRegOff (char '-') (-i)
      where
	pprRegOff op i' = pprCastReg reg <> op <> int i'

    CmmMachOp mop args -> pprMachOpApp mop args

348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373

pprLoad :: CmmExpr -> CmmType -> SDoc
pprLoad e ty
  | width == W64, wordWidth /= W64
  = (if isFloatType ty then ptext (sLit "PK_DBL")
	    	       else ptext (sLit "PK_Word64"))
    <> parens (mkP_ <> pprExpr1 e)

  | otherwise 
  = case e of
	CmmReg r | isPtrReg r && width == wordWidth && not (isFloatType ty)
		 -> char '*' <> pprAsPtrReg r

	CmmRegOff r 0 | isPtrReg r && width == wordWidth && not (isFloatType ty)
		      -> char '*' <> pprAsPtrReg r

	CmmRegOff r off | isPtrReg r && width == wordWidth
			, off `rem` wORD_SIZE == 0 && not (isFloatType ty)
	-- ToDo: check that the offset is a word multiple?
        --       (For tagging to work, I had to avoid unaligned loads. --ARY)
			-> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift))

	_other -> cLoad e ty
  where
    width = typeWidth ty

374 375 376 377 378 379 380 381 382 383 384 385
pprExpr1 :: CmmExpr -> SDoc
pprExpr1 (CmmLit lit) 	  = pprLit1 lit
pprExpr1 e@(CmmReg _reg)  = pprExpr e
pprExpr1 other            = parens (pprExpr other)

-- --------------------------------------------------------------------------
-- MachOp applications

pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc

pprMachOpApp op args
  | isMulMayOfloOp op
Ian Lynagh's avatar
Ian Lynagh committed
386
  = ptext (sLit "mulIntMayOflo") <> parens (commafy (map pprExpr args))
387 388 389 390 391
  where isMulMayOfloOp (MO_U_MulMayOflo _) = True
	isMulMayOfloOp (MO_S_MulMayOflo _) = True
	isMulMayOfloOp _ = False

pprMachOpApp mop args
392 393 394 395 396 397 398 399 400 401 402 403 404 405
  | Just ty <- machOpNeedsCast mop 
  = ty <> parens (pprMachOpApp' mop args)
  | otherwise
  = pprMachOpApp' mop args

-- Comparisons in C have type 'int', but we want type W_ (this is what
-- resultRepOfMachOp says).  The other C operations inherit their type
-- from their operands, so no casting is required.
machOpNeedsCast :: MachOp -> Maybe SDoc
machOpNeedsCast mop
  | isComparisonMachOp mop = Just mkW_
  | otherwise              = Nothing

pprMachOpApp' mop args
406 407 408 409 410 411 412 413 414 415
 = case args of
    -- dyadic
    [x,y] -> pprArg x <+> pprMachOp_for_C mop <+> pprArg y

    -- unary
    [x]   -> pprMachOp_for_C mop <> parens (pprArg x)

    _     -> panic "PprC.pprMachOp : machop with wrong number of args"

  where
416 417 418
	-- Cast needed for signed integer ops
    pprArg e | signedOp    mop = cCast (machRep_S_CType (typeWidth (cmmExprType e))) e
             | needsFCasts mop = cCast (machRep_F_CType (typeWidth (cmmExprType e))) e
419
 	     | otherwise    = pprExpr1 e
420 421 422 423 424
    needsFCasts (MO_F_Eq _)   = False
    needsFCasts (MO_F_Ne _)   = False
    needsFCasts (MO_F_Neg _)  = True
    needsFCasts (MO_F_Quot _) = True
    needsFCasts mop  = floatComparison mop
425 426 427 428 429 430

-- --------------------------------------------------------------------------
-- Literals

pprLit :: CmmLit -> SDoc
pprLit lit = case lit of
431
    CmmInt i rep      -> pprHexVal i rep
432

433
    CmmFloat f w       -> parens (machRep_F_CType w) <> str
434 435 436 437 438 439 440 441
        where d = fromRational f :: Double
              str | isInfinite d && d < 0 = ptext (sLit "-INFINITY")
                  | isInfinite d          = ptext (sLit "INFINITY")
                  | isNaN d               = ptext (sLit "NAN")
                  | otherwise             = text (show d)
                -- these constants come from <math.h>
                -- see #1861

442 443
    CmmBlock bid       -> mkW_ <> pprCLabelAddr (infoTblLbl bid)
    CmmHighStackMark   -> panic "PprC printing high stack mark"
444 445
    CmmLabel clbl      -> mkW_ <> pprCLabelAddr clbl
    CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i
446 447
    CmmLabelDiffOff clbl1 clbl2 i
        -- WARNING:
448 449
        --  * the lit must occur in the info table clbl2
        --  * clbl1 must be an SRT, a slow entry point or a large bitmap
450 451 452
        -- The Mangler is expected to convert any reference to an SRT,
        -- a slow entry point or a large bitmap
        -- from an info table to an offset.
453 454 455
        -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i

pprCLabelAddr lbl = char '&' <> pprCLabel lbl
456 457 458

pprLit1 :: CmmLit -> SDoc
pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)
459
pprLit1 lit@(CmmLabelDiffOff _ _ _) = parens (pprLit lit)
460 461 462 463 464 465 466 467
pprLit1 lit@(CmmFloat _ _)    = parens (pprLit lit)
pprLit1 other = pprLit other

-- ---------------------------------------------------------------------------
-- Static data

pprStatics :: [CmmStatic] -> [SDoc]
pprStatics [] = []
468
pprStatics (CmmStaticLit (CmmFloat f W32) : rest) 
469
  -- floats are padded to a word, see #1852
470
  | wORD_SIZE == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest
471 472
  = pprLit1 (floatToWord f) : pprStatics rest'
  | wORD_SIZE == 4
473
  = pprLit1 (floatToWord f) : pprStatics rest
474
  | otherwise
475 476
  = pprPanic "pprStatics: float" (vcat (map (\(CmmStaticLit l) -> ppr (cmmLitType l)) rest))
pprStatics (CmmStaticLit (CmmFloat f W64) : rest)
477
  = map pprLit1 (doubleToWords f) ++ pprStatics rest
478 479
pprStatics (CmmStaticLit (CmmInt i W64) : rest)
  | wordWidth == W32
480
#ifdef WORDS_BIGENDIAN
481 482
  = pprStatics (CmmStaticLit (CmmInt q W32) : 
		CmmStaticLit (CmmInt r W32) : rest)
483
#else
484 485
  = pprStatics (CmmStaticLit (CmmInt r W32) : 
		CmmStaticLit (CmmInt q W32) : rest)
486 487 488
#endif
  where r = i .&. 0xffffffff
	q = i `shiftR` 32
489 490
pprStatics (CmmStaticLit (CmmInt i w) : rest)
  | w /= wordWidth
491
  = panic "pprStatics: cannot emit a non-word-sized static literal"
492 493 494 495 496 497 498 499 500
pprStatics (CmmStaticLit lit : rest)
  = pprLit1 lit : pprStatics rest
pprStatics (other : rest)
  = pprPanic "pprWord" (pprStatic other)

pprStatic :: CmmStatic -> SDoc
pprStatic s = case s of

    CmmStaticLit lit   -> nest 4 (pprLit lit)
Ian Lynagh's avatar
Ian Lynagh committed
501
    CmmAlign i         -> nest 4 (ptext (sLit "/* align */") <+> int i)
502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525
    CmmDataLabel clbl  -> pprCLabel clbl <> colon
    CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i))

    -- these should be inlined, like the old .hc
    CmmString s'       -> nest 4 (mkW_ <> parens(pprStringInCStyle s'))


-- ---------------------------------------------------------------------------
-- Block Ids

pprBlockId :: BlockId -> SDoc
pprBlockId b = char '_' <> ppr (getUnique b)

-- --------------------------------------------------------------------------
-- Print a MachOp in a way suitable for emitting via C.
--

pprMachOp_for_C :: MachOp -> SDoc

pprMachOp_for_C mop = case mop of 

        -- Integer operations
        MO_Add          _ -> char '+'
        MO_Sub          _ -> char '-'
Ian Lynagh's avatar
Ian Lynagh committed
526 527
        MO_Eq           _ -> ptext (sLit "==")
        MO_Ne           _ -> ptext (sLit "!=")
528 529 530 531 532 533 534 535 536
        MO_Mul          _ -> char '*'

        MO_S_Quot       _ -> char '/'
        MO_S_Rem        _ -> char '%'
        MO_S_Neg        _ -> char '-'

        MO_U_Quot       _ -> char '/'
        MO_U_Rem        _ -> char '%'

537 538 539 540 541 542 543 544
        -- & Floating-point operations
        MO_F_Add        _ -> char '+'
        MO_F_Sub        _ -> char '-'
        MO_F_Neg        _ -> char '-'
        MO_F_Mul        _ -> char '*'
        MO_F_Quot       _ -> char '/'

        -- Signed comparisons
Ian Lynagh's avatar
Ian Lynagh committed
545 546
        MO_S_Ge         _ -> ptext (sLit ">=")
        MO_S_Le         _ -> ptext (sLit "<=")
547 548 549
        MO_S_Gt         _ -> char '>'
        MO_S_Lt         _ -> char '<'

550
        -- & Unsigned comparisons
Ian Lynagh's avatar
Ian Lynagh committed
551 552
        MO_U_Ge         _ -> ptext (sLit ">=")
        MO_U_Le         _ -> ptext (sLit "<=")
553 554 555
        MO_U_Gt         _ -> char '>'
        MO_U_Lt         _ -> char '<'

556 557 558 559 560 561 562 563
        -- & Floating-point comparisons
        MO_F_Eq         _ -> ptext (sLit "==")
        MO_F_Ne         _ -> ptext (sLit "!=")
        MO_F_Ge         _ -> ptext (sLit ">=")
        MO_F_Le         _ -> ptext (sLit "<=")
        MO_F_Gt         _ -> char '>'
        MO_F_Lt         _ -> char '<'

564 565 566 567 568 569
        -- Bitwise operations.  Not all of these may be supported at all
        -- sizes, and only integral MachReps are valid.
        MO_And          _ -> char '&'
        MO_Or           _ -> char '|'
        MO_Xor          _ -> char '^'
        MO_Not          _ -> char '~'
Ian Lynagh's avatar
Ian Lynagh committed
570 571 572
        MO_Shl          _ -> ptext (sLit "<<")
        MO_U_Shr        _ -> ptext (sLit ">>") -- unsigned shift right
        MO_S_Shr        _ -> ptext (sLit ">>") -- signed shift right
573

574 575
-- Conversions.  Some of these will be NOPs, but never those that convert
-- between ints and floats.
576 577 578 579 580
-- Floating-point conversions use the signed variant.
-- We won't know to generate (void*) casts here, but maybe from
-- context elsewhere

-- noop casts
581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598
        MO_UU_Conv from to | from == to -> empty
	MO_UU_Conv _from to  -> parens (machRep_U_CType to)

        MO_SS_Conv from to | from == to -> empty
	MO_SS_Conv _from to  -> parens (machRep_S_CType to)

        -- TEMPORARY: the old code didn't check this case, so let's leave it out
        -- to facilitate comparisons against the old output code.
        --MO_FF_Conv from to | from == to -> empty
	MO_FF_Conv _from to  -> parens (machRep_F_CType to)

	MO_SF_Conv _from to  -> parens (machRep_F_CType to)
	MO_FS_Conv _from to  -> parens (machRep_S_CType to)

        _ -> pprTrace "offending mop" (ptext $ sLit $ show mop) $
             panic "PprC.pprMachOp_for_C: unknown machop"

signedOp :: MachOp -> Bool	-- Argument type(s) are signed ints
599 600 601 602 603 604 605 606
signedOp (MO_S_Quot _)	 = True
signedOp (MO_S_Rem  _)	 = True
signedOp (MO_S_Neg  _)	 = True
signedOp (MO_S_Ge   _)	 = True
signedOp (MO_S_Le   _)	 = True
signedOp (MO_S_Gt   _)	 = True
signedOp (MO_S_Lt   _)	 = True
signedOp (MO_S_Shr  _)	 = True
607 608
signedOp (MO_SS_Conv _ _) = True
signedOp (MO_SF_Conv _ _) = True
609 610
signedOp _ = False

611 612 613 614 615 616 617 618 619
floatComparison :: MachOp -> Bool  -- comparison between float args
floatComparison (MO_F_Eq   _)	 = True
floatComparison (MO_F_Ne   _)	 = True
floatComparison (MO_F_Ge   _)	 = True
floatComparison (MO_F_Le   _)	 = True
floatComparison (MO_F_Gt   _)	 = True
floatComparison (MO_F_Lt   _)	 = True
floatComparison _ = False

620 621 622 623 624 625 626
-- ---------------------------------------------------------------------
-- tend to be implemented by foreign calls

pprCallishMachOp_for_C :: CallishMachOp -> SDoc

pprCallishMachOp_for_C mop 
    = case mop of
Ian Lynagh's avatar
Ian Lynagh committed
627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653
        MO_F64_Pwr  -> ptext (sLit "pow")
        MO_F64_Sin  -> ptext (sLit "sin")
        MO_F64_Cos  -> ptext (sLit "cos")
        MO_F64_Tan  -> ptext (sLit "tan")
        MO_F64_Sinh -> ptext (sLit "sinh")
        MO_F64_Cosh -> ptext (sLit "cosh")
        MO_F64_Tanh -> ptext (sLit "tanh")
        MO_F64_Asin -> ptext (sLit "asin")
        MO_F64_Acos -> ptext (sLit "acos")
        MO_F64_Atan -> ptext (sLit "atan")
        MO_F64_Log  -> ptext (sLit "log")
        MO_F64_Exp  -> ptext (sLit "exp")
        MO_F64_Sqrt -> ptext (sLit "sqrt")
        MO_F32_Pwr  -> ptext (sLit "powf")
        MO_F32_Sin  -> ptext (sLit "sinf")
        MO_F32_Cos  -> ptext (sLit "cosf")
        MO_F32_Tan  -> ptext (sLit "tanf")
        MO_F32_Sinh -> ptext (sLit "sinhf")
        MO_F32_Cosh -> ptext (sLit "coshf")
        MO_F32_Tanh -> ptext (sLit "tanhf")
        MO_F32_Asin -> ptext (sLit "asinf")
        MO_F32_Acos -> ptext (sLit "acosf")
        MO_F32_Atan -> ptext (sLit "atanf")
        MO_F32_Log  -> ptext (sLit "logf")
        MO_F32_Exp  -> ptext (sLit "expf")
        MO_F32_Sqrt -> ptext (sLit "sqrtf")
	MO_WriteBarrier -> ptext (sLit "write_barrier")
654 655 656 657 658 659 660

-- ---------------------------------------------------------------------
-- Useful #defines
--

mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc

Ian Lynagh's avatar
Ian Lynagh committed
661 662 663
mkJMP_ i = ptext (sLit "JMP_") <> parens i
mkFN_  i = ptext (sLit "FN_")  <> parens i -- externally visible function
mkIF_  i = ptext (sLit "IF_")  <> parens i -- locally visible
664 665 666


mkFB_, mkFE_ :: SDoc
Ian Lynagh's avatar
Ian Lynagh committed
667 668
mkFB_ = ptext (sLit "FB_") -- function code begin
mkFE_ = ptext (sLit "FE_") -- function code end
669 670 671 672 673

-- from includes/Stg.h
--
mkC_,mkW_,mkP_,mkPP_,mkI_,mkA_,mkD_,mkF_,mkB_,mkL_,mkLI_,mkLW_ :: SDoc

Ian Lynagh's avatar
Ian Lynagh committed
674 675 676 677 678 679 680 681 682 683
mkC_  = ptext (sLit "(C_)")        -- StgChar
mkW_  = ptext (sLit "(W_)")        -- StgWord
mkP_  = ptext (sLit "(P_)")        -- StgWord*
mkPP_ = ptext (sLit "(PP_)")       -- P_*
mkI_  = ptext (sLit "(I_)")        -- StgInt
mkA_  = ptext (sLit "(A_)")        -- StgAddr
mkD_  = ptext (sLit "(D_)")        -- const StgWord*
mkF_  = ptext (sLit "(F_)")        -- StgFunPtr
mkB_  = ptext (sLit "(B_)")        -- StgByteArray
mkL_  = ptext (sLit "(L_)")        -- StgClosurePtr
684

Ian Lynagh's avatar
Ian Lynagh committed
685 686
mkLI_ = ptext (sLit "(LI_)")       -- StgInt64
mkLW_ = ptext (sLit "(LW_)")       -- StgWord64
687 688 689 690 691 692 693 694 695 696 697 698


-- ---------------------------------------------------------------------
--
-- Assignments
--
-- Generating assignments is what we're all about, here
--
pprAssign :: CmmReg -> CmmExpr -> SDoc

-- dest is a reg, rhs is a reg
pprAssign r1 (CmmReg r2)
699
   | isPtrReg r1 && isPtrReg r2
700 701 702 703
   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ]

-- dest is a reg, rhs is a CmmRegOff
pprAssign r1 (CmmRegOff r2 off)
704
   | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE == 0)
705 706
   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]
  where
707
	off1 = off `shiftR` wordShift
708 709 710 711

	(op,off') | off >= 0  = (char '+', off1)
		  | otherwise = (char '-', -off1)

712 713 714
-- dest is a reg, rhs is anything.
-- We can't cast the lvalue, so we have to cast the rhs if necessary.  Casting
-- the lvalue elicits a warning from new GCC versions (3.4+).
715
pprAssign r1 r2
Ian Lynagh's avatar
Ian Lynagh committed
716 717 718 719
  | isFixedPtrReg r1             = mkAssign (mkP_ <> pprExpr1 r2)
  | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2)
  | otherwise                    = mkAssign (pprExpr r2)
    where mkAssign x = if r1 == CmmGlobal BaseReg
Ian Lynagh's avatar
Ian Lynagh committed
720 721
                       then ptext (sLit "ASSIGN_BaseReg") <> parens x <> semi
                       else pprReg r1 <> ptext (sLit " = ") <> x <> semi
722 723 724 725 726 727 728 729

-- ---------------------------------------------------------------------
-- Registers

pprCastReg reg
   | isStrangeTypeReg reg = mkW_ <> pprReg reg
   | otherwise            = pprReg reg

730 731 732 733 734 735
-- True if (pprReg reg) will give an expression with type StgPtr.  We
-- need to take care with pointer arithmetic on registers with type
-- StgPtr.
isFixedPtrReg :: CmmReg -> Bool
isFixedPtrReg (CmmLocal _) = False
isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r
736

737
-- True if (pprAsPtrReg reg) will give an expression with type StgPtr
738 739 740
-- JD: THIS IS HORRIBLE AND SHOULD BE RENAMED, AT THE VERY LEAST.
-- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT;
-- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY.
741 742
isPtrReg :: CmmReg -> Bool
isPtrReg (CmmLocal _) 		    = False
743 744
isPtrReg (CmmGlobal (VanillaReg n VGcPtr)) = True -- if we print via pprAsPtrReg
isPtrReg (CmmGlobal (VanillaReg n VNonGcPtr)) = False --if we print via pprAsPtrReg
745 746 747 748 749 750 751 752 753
isPtrReg (CmmGlobal reg)	    = isFixedPtrGlobalReg reg

-- True if this global reg has type StgPtr
isFixedPtrGlobalReg :: GlobalReg -> Bool
isFixedPtrGlobalReg Sp 		= True
isFixedPtrGlobalReg Hp 		= True
isFixedPtrGlobalReg HpLim	= True
isFixedPtrGlobalReg SpLim	= True
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 758 759 760 761 762 763
isStrangeTypeReg :: CmmReg -> Bool
isStrangeTypeReg (CmmLocal _) 	= False
isStrangeTypeReg (CmmGlobal g) 	= isStrangeTypeGlobal g

isStrangeTypeGlobal :: GlobalReg -> Bool
isStrangeTypeGlobal CurrentTSO		= True
isStrangeTypeGlobal CurrentNursery 	= True
764
isStrangeTypeGlobal BaseReg	 	= True
765
isStrangeTypeGlobal r 			= isFixedPtrGlobalReg r
766

767
strangeRegType :: CmmReg -> Maybe SDoc
Ian Lynagh's avatar
Ian Lynagh committed
768 769 770
strangeRegType (CmmGlobal CurrentTSO) = Just (ptext (sLit "struct StgTSO_ *"))
strangeRegType (CmmGlobal CurrentNursery) = Just (ptext (sLit "struct bdescr_ *"))
strangeRegType (CmmGlobal BaseReg) = Just (ptext (sLit "struct StgRegTable_ *"))
771
strangeRegType _ = Nothing
772 773 774 775 776 777 778 779 780

-- pprReg just prints the register name.
--
pprReg :: CmmReg -> SDoc
pprReg r = case r of
        CmmLocal  local  -> pprLocalReg local
        CmmGlobal global -> pprGlobalReg global
		
pprAsPtrReg :: CmmReg -> SDoc
781 782
pprAsPtrReg (CmmGlobal (VanillaReg n gcp)) 
  = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> ptext (sLit ".p")
783 784 785 786
pprAsPtrReg other_reg = pprReg other_reg

pprGlobalReg :: GlobalReg -> SDoc
pprGlobalReg gr = case gr of
787 788 789 790
    VanillaReg n _ -> char 'R' <> int n  <> ptext (sLit ".w")
	-- pprGlobalReg prints a VanillaReg as a .w regardless
	-- Example:	R1.w = R1.w & (-0x8UL);
	--		JMP_(*R1.p);
791 792 793
    FloatReg   n   -> char 'F' <> int n
    DoubleReg  n   -> char 'D' <> int n
    LongReg    n   -> char 'L' <> int n
Ian Lynagh's avatar
Ian Lynagh committed
794 795 796 797 798 799 800 801
    Sp             -> ptext (sLit "Sp")
    SpLim          -> ptext (sLit "SpLim")
    Hp             -> ptext (sLit "Hp")
    HpLim          -> ptext (sLit "HpLim")
    CurrentTSO     -> ptext (sLit "CurrentTSO")
    CurrentNursery -> ptext (sLit "CurrentNursery")
    HpAlloc        -> ptext (sLit "HpAlloc")
    BaseReg        -> ptext (sLit "BaseReg")
802
    EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info")
Ian Lynagh's avatar
Ian Lynagh committed
803 804
    GCEnter1       -> ptext (sLit "stg_gc_enter_1")
    GCFun          -> ptext (sLit "stg_gc_fun")
805 806

pprLocalReg :: LocalReg -> SDoc
807
pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq
808 809 810 811

-- -----------------------------------------------------------------------------
-- Foreign Calls

812
pprCall :: SDoc -> CCallConv -> HintedCmmFormals -> HintedCmmActuals -> CmmSafety
813
	-> SDoc
814

815
pprCall ppr_fn cconv results args _
816
  | not (is_cish cconv)
Simon Marlow's avatar
Simon Marlow committed
817
  = panic "pprCall: unknown calling convention"
818 819

  | otherwise
820
  =
821 822 823 824 825 826 827
#if x86_64_TARGET_ARCH
	-- HACK around gcc optimisations.
	-- x86_64 needs a __DISCARD__() here, to create a barrier between
	-- putting the arguments into temporaries and passing the arguments
	-- to the callee, because the argument expressions may refer to
	-- machine registers that are also used for passing arguments in the
	-- C calling convention.
828
    (if (not opt_Unregisterised) 
Ian Lynagh's avatar
Ian Lynagh committed
829
	then ptext (sLit "__DISCARD__();") 
830
	else empty) $$
831
#endif
832
    ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
833
  where 
Simon Marlow's avatar
Simon Marlow committed
834
     ppr_assign []           rhs = rhs
835
     ppr_assign [CmmHinted one hint] rhs
Ian Lynagh's avatar
Ian Lynagh committed
836
	 = pprLocalReg one <> ptext (sLit " = ")
837
		 <> pprUnHint hint (localRegType one) <> rhs
Simon Marlow's avatar
Simon Marlow committed
838
     ppr_assign _other _rhs = panic "pprCall: multiple results"
839

840 841
     pprArg (CmmHinted expr AddrHint)
   	= cCast (ptext (sLit "void *")) expr
842
	-- see comment by machRepHintCType below
843 844 845 846
     pprArg (CmmHinted expr SignedHint)
	= cCast (machRep_S_CType $ typeWidth $ cmmExprType expr) expr
     pprArg (CmmHinted expr _other)
	= pprExpr expr
847

848
     pprUnHint AddrHint   rep = parens (machRepCType rep)
849 850 851
     pprUnHint SignedHint rep = parens (machRepCType rep)
     pprUnHint _          _   = empty

852 853
pprGlobalRegName :: GlobalReg -> SDoc
pprGlobalRegName gr = case gr of
854 855
    VanillaReg n _  -> char 'R' <> int n  -- without the .w suffix
    _               -> pprGlobalReg gr
856

857 858
-- Currently we only have these two calling conventions, but this might
-- change in the future...
859 860 861 862 863 864 865 866 867
is_cish CCallConv   = True
is_cish StdCallConv = True

-- ---------------------------------------------------------------------
-- Find and print local and external declarations for a list of
-- Cmm statements.
-- 
pprTempAndExternDecls :: [CmmBasicBlock] -> (SDoc{-temps-}, SDoc{-externs-})
pprTempAndExternDecls stmts 
868
  = (vcat (map pprTempDecl (uniqSetToList temps)), 
869 870 871 872 873 874 875 876 877
     vcat (map (pprExternDecl False{-ToDo-}) (keysFM lbls)))
  where (temps, lbls) = runTE (mapM_ te_BB stmts)

pprDataExterns :: [CmmStatic] -> SDoc
pprDataExterns statics
  = vcat (map (pprExternDecl False{-ToDo-}) (keysFM lbls))
  where (_, lbls) = runTE (mapM_ te_Static statics)

pprTempDecl :: LocalReg -> SDoc
878
pprTempDecl l@(LocalReg _ rep)
879 880 881 882 883 884
  = hcat [ machRepCType rep, space, pprLocalReg l, semi ]

pprExternDecl :: Bool -> CLabel -> SDoc
pprExternDecl in_srt lbl
  -- do not print anything for "known external" things
  | not (needsCDecl lbl) = empty
885 886
  | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz
  | otherwise =
887
	hcat [ visibility, label_type lbl,
888
	       lparen, pprCLabel lbl, text ");" ]
889
 where
890 891
  label_type lbl | isCFunctionLabel lbl = ptext (sLit "F_")
		 | otherwise		= ptext (sLit "I_")
892 893 894 895 896

  visibility
     | externallyVisibleCLabel lbl = char 'E'
     | otherwise		   = char 'I'

897 898 899 900 901
  -- If the label we want to refer to is a stdcall function (on Windows) then
  -- we must generate an appropriate prototype for it, so that the C compiler will
  -- add the @n suffix to the label (#2276)
  stdcall_decl sz =
        ptext (sLit "extern __attribute__((stdcall)) void ") <> pprCLabel lbl
902
        <> parens (commafy (replicate (sz `quot` wORD_SIZE) (machRep_U_CType wordWidth)))
903
        <> semi
904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929

type TEState = (UniqSet LocalReg, FiniteMap CLabel ())
newtype TE a = TE { unTE :: TEState -> (a, TEState) }

instance Monad TE where
   TE m >>= k  = TE $ \s -> case m s of (a, s') -> unTE (k a) s'
   return a    = TE $ \s -> (a, s)

te_lbl :: CLabel -> TE ()
te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, addToFM lbls lbl ()))

te_temp :: LocalReg -> TE ()
te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls))

runTE :: TE () -> TEState
runTE (TE m) = snd (m (emptyUniqSet, emptyFM))

te_Static :: CmmStatic -> TE ()
te_Static (CmmStaticLit lit) = te_Lit lit
te_Static _ = return ()

te_BB :: CmmBasicBlock -> TE ()
te_BB (BasicBlock _ ss)		= mapM_ te_Stmt ss

te_Lit :: CmmLit -> TE ()
te_Lit (CmmLabel l) = te_lbl l
930 931
te_Lit (CmmLabelOff l _) = te_lbl l
te_Lit (CmmLabelDiffOff l1 l2 _) = te_lbl l1
932 933 934 935 936
te_Lit _ = return ()

te_Stmt :: CmmStmt -> TE ()
te_Stmt (CmmAssign r e)		= te_Reg r >> te_Expr e
te_Stmt (CmmStore l r)		= te_Expr l >> te_Expr r
937 938
te_Stmt (CmmCall _ rs es _ _)	= mapM_ (te_temp.hintlessCmm) rs >>
				  mapM_ (te_Expr.hintlessCmm) es
939 940 941 942 943 944 945 946
te_Stmt (CmmCondBranch e _)	= te_Expr e
te_Stmt (CmmSwitch e _)		= te_Expr e
te_Stmt (CmmJump e _)		= te_Expr e
te_Stmt _			= return ()

te_Expr :: CmmExpr -> TE ()
te_Expr (CmmLit lit)		= te_Lit lit
te_Expr (CmmLoad e _)		= te_Expr e
947
te_Expr (CmmReg r)		= te_Reg r
948 949 950 951 952 953 954 955 956 957 958 959 960 961
te_Expr (CmmMachOp _ es) 	= mapM_ te_Expr es
te_Expr (CmmRegOff r _) 	= te_Reg r

te_Reg :: CmmReg -> TE ()
te_Reg (CmmLocal l) = te_temp l
te_Reg _            = return ()


-- ---------------------------------------------------------------------
-- C types for MachReps

cCast :: SDoc -> CmmExpr -> SDoc
cCast ty expr = parens ty <> pprExpr1 expr

962
cLoad :: CmmExpr -> CmmType -> SDoc
963 964
#ifdef BEWARE_LOAD_STORE_ALIGNMENT
cLoad expr rep =
Ian Lynagh's avatar
Ian Lynagh committed
965 966 967
    let decl = machRepCType rep <+> ptext (sLit "x") <> semi
        struct = ptext (sLit "struct") <+> braces (decl)
        packed_attr = ptext (sLit "__attribute__((packed))")
968
        cast = parens (struct <+> packed_attr <> char '*')
Ian Lynagh's avatar
Ian Lynagh committed
969
    in parens (cast <+> pprExpr1 expr) <> ptext (sLit "->x")
970 971 972 973
#else
cLoad expr rep = char '*' <> parens (cCast (machRepPtrCType rep) expr)
#endif

974 975 976 977 978
isCmmWordType :: CmmType -> Bool
-- True of GcPtrReg/NonGcReg of native word size
isCmmWordType ty = not (isFloatType ty) 
		   && typeWidth ty == wordWidth

979 980 981
-- This is for finding the types of foreign call arguments.  For a pointer
-- argument, we always cast the argument to (void *), to avoid warnings from
-- the C compiler.
982 983 984
machRepHintCType :: CmmType -> ForeignHint -> SDoc
machRepHintCType rep AddrHint    = ptext (sLit "void *")
machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep)
985 986
machRepHintCType rep _other     = machRepCType rep

987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017
machRepPtrCType :: CmmType -> SDoc
machRepPtrCType r | isCmmWordType r = ptext (sLit "P_")
	          | otherwise       = machRepCType r <> char '*'

machRepCType :: CmmType -> SDoc
machRepCType ty | isFloatType ty = machRep_F_CType w
		| otherwise	 = machRep_U_CType w
		where
		  w = typeWidth ty

machRep_F_CType :: Width -> SDoc
machRep_F_CType W32 = ptext (sLit "StgFloat") -- ToDo: correct?
machRep_F_CType W64 = ptext (sLit "StgDouble")
machRep_F_CType _   = panic "machRep_F_CType"

machRep_U_CType :: Width -> SDoc
machRep_U_CType w | w == wordWidth = ptext (sLit "W_")
machRep_U_CType W8  = ptext (sLit "StgWord8")
machRep_U_CType W16 = ptext (sLit "StgWord16")
machRep_U_CType W32 = ptext (sLit "StgWord32")
machRep_U_CType W64 = ptext (sLit "StgWord64")
machRep_U_CType _   = panic "machRep_U_CType"

machRep_S_CType :: Width -> SDoc
machRep_S_CType w | w == wordWidth = ptext (sLit "I_")
machRep_S_CType W8  = ptext (sLit "StgInt8")
machRep_S_CType W16 = ptext (sLit "StgInt16")
machRep_S_CType W32 = ptext (sLit "StgInt32")
machRep_S_CType W64 = ptext (sLit "StgInt64")
machRep_S_CType _   = panic "machRep_S_CType"
  
1018 1019 1020 1021

-- ---------------------------------------------------------------------
-- print strings as valid C strings

1022
pprStringInCStyle :: [Word8] -> SDoc
1023 1024
pprStringInCStyle s = doubleQuotes (text (concatMap charToC s))

1025 1026 1027 1028 1029 1030 1031 1032
charToC :: Word8 -> String
charToC w = 
  case chr (fromIntegral w) of
	'\"' -> "\\\""
	'\'' -> "\\\'"
	'\\' -> "\\\\"
	c | c >= ' ' && c <= '~' -> [c]
          | otherwise -> ['\\',
1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045
                         chr (ord '0' + ord c `div` 64),
                         chr (ord '0' + ord c `div` 8 `mod` 8),
                         chr (ord '0' + ord c         `mod` 8)]

-- ---------------------------------------------------------------------------
-- Initialising static objects with floating-point numbers.  We can't
-- just emit the floating point number, because C will cast it to an int
-- by rounding it.  We want the actual bit-representation of the float.

-- This is a hack to turn the floating point numbers into ints that we
-- can safely initialise to static locations.

big_doubles 
1046 1047
  | widthInBytes W64 == 2 * wORD_SIZE  = True
  | widthInBytes W64 == wORD_SIZE      = False
1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059
  | otherwise = panic "big_doubles"

castFloatToIntArray :: STUArray s Int Float -> ST s (STUArray s Int Int)
castFloatToIntArray = castSTUArray

castDoubleToIntArray :: STUArray s Int Double -> ST s (STUArray s Int Int)
castDoubleToIntArray = castSTUArray

-- floats are always 1 word
floatToWord :: Rational -> CmmLit
floatToWord r
  = runST (do
1060 1061
	arr <- newArray_ ((0::Int),0)
	writeArray arr 0 (fromRational r)
1062
	arr' <- castFloatToIntArray arr
1063
	i <- readArray arr' 0
1064
	return (CmmInt (toInteger i) wordWidth)
1065 1066 1067 1068 1069 1070
    )

doubleToWords :: Rational -> [CmmLit]
doubleToWords r
  | big_doubles				-- doubles are 2 words
  = runST (do
1071 1072
	arr <- newArray_ ((0::Int),1)
	writeArray arr 0 (fromRational r)
1073
	arr' <- castDoubleToIntArray arr
1074 1075
	i1 <- readArray arr' 0
	i2 <- readArray arr' 1
1076 1077
	return [ CmmInt (toInteger i1) wordWidth
	       , CmmInt (toInteger i2) wordWidth
1078 1079 1080 1081
	       ]
    )
  | otherwise				-- doubles are 1 word
  = runST (do
1082 1083
	arr <- newArray_ ((0::Int),0)
	writeArray arr 0 (fromRational r)
1084
	arr' <- castDoubleToIntArray arr
1085
	i <- readArray arr' 0
1086
	return [ CmmInt (toInteger i) wordWidth ]
1087 1088 1089 1090 1091 1092
    )

-- ---------------------------------------------------------------------------
-- Utils

wordShift :: Int
1093
wordShift = widthInLog wordWidth
1094 1095 1096 1097 1098

commafy :: [SDoc] -> SDoc
commafy xs = hsep $ punctuate comma xs

-- Print in C hex format: 0x13fa
1099
pprHexVal :: Integer -> Width -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
1100
pprHexVal 0 _ = ptext (sLit "0x0")
1101
pprHexVal w rep
Ian Lynagh's avatar
Ian Lynagh committed
1102 1103
  | w < 0     = parens (char '-' <> ptext (sLit "0x") <> go (-w) <> repsuffix rep)
  | otherwise = ptext (sLit "0x") <> go w <> repsuffix rep
1104
  where
1105
  	-- type suffix for literals:
1106 1107 1108 1109 1110 1111
	-- Integer literals are unsigned in Cmm/C.  We explicitly cast to
	-- signed values for doing signed operations, but at all other
	-- times values are unsigned.  This also helps eliminate occasional
	-- warnings about integer overflow from gcc.

	-- 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 1118 1119 1120 1121 1122 1123
      go 0 = empty
      go w' = go q <> dig
           where
             (q,r) = w' `quotRem` 16
             dig | r < 10    = char (chr (fromInteger r + ord '0'))
                 | otherwise = char (chr (fromInteger r - 10 + ord 'a'))