PprC.hs 31.3 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32
-----------------------------------------------------------------------------
--
-- Pretty-printing of Cmm as C, suitable for feeding gcc
--
-- (c) The University of Glasgow 2004
--
-----------------------------------------------------------------------------

--
-- Print Cmm as real C, for -fvia-C
--
-- 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

#include "HsVersions.h"

-- Cmm stuff
import Cmm
import CLabel
import MachOp
import ForeignCall

-- Utils
33
import DynFlags		( DynFlags, DynFlag(..), dopt )
34 35 36 37 38 39 40 41 42
import Unique           ( getUnique )
import UniqSet
import FiniteMap
import UniqFM		( eltsUFM )
import FastString
import Outputable
import Constants

-- The rest
43
import Data.List        ( intersperse, groupBy )
44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61
import Data.Bits        ( shiftR )
import Char             ( ord, chr )
import IO               ( Handle )
import DATA_BITS

#ifdef DEBUG
import PprCmm		() -- instances only
-- import Debug.Trace
#endif

#if __GLASGOW_HASKELL__ >= 504
import Data.Array.ST
#endif
import MONAD_ST

-- --------------------------------------------------------------------------
-- Top level

62 63 64 65 66 67 68 69 70 71 72 73
pprCs :: DynFlags -> [Cmm] -> SDoc
pprCs dflags cmms
 = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms)
 where
   split_marker
     | dopt Opt_SplitObjs dflags = ptext SLIT("__STG_SPLIT_MARKER")
     | otherwise     	         = empty

writeCs :: DynFlags -> Handle -> [Cmm] -> IO ()
writeCs dflags handle cmms 
  = printForUser handle alwaysQualify (pprCs dflags cmms)
 	-- ToDo: should be printForC
74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89

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

pprC :: Cmm -> SDoc
pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops

--
-- top level procs
-- 
pprTop :: CmmTop -> SDoc
pprTop (CmmProc info clbl _params blocks) =
    (if not (null info)
90 91
        then pprDataExterns info $$
             pprWordArray (entryLblToInfoLbl clbl) info
92 93 94 95 96 97 98 99 100 101 102 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 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 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 175 176 177 178 179 180 181 182
        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 [
    pprLocalness lbl, ptext SLIT("char "), pprCLabel lbl,
    ptext SLIT("[] = "), pprStringInCStyle str, semi
  ]

pprTop (CmmData _section _ds@[CmmDataLabel lbl, CmmUninitialised size]) = 
  hcat [
    pprLocalness lbl, ptext SLIT("char "), pprCLabel lbl,
    brackets (int size), semi
  ]

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

-- 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
  = hcat [ pprLocalness lbl, ptext SLIT("StgWord")
         , space, pprCLabel lbl, ptext SLIT("[] = {") ] 
    $$ nest 8 (commafy (pprStatics ds))
    $$ ptext SLIT("};")

--
-- has to be static, if it isn't globally visible
--
pprLocalness :: CLabel -> SDoc
pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext SLIT("static ")
                 | otherwise = empty

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

pprStmt :: CmmStmt -> SDoc

pprStmt stmt = case stmt of
    CmmNop       -> empty
    CmmComment s -> (hang (ptext SLIT("/*")) 3 (ftext s)) $$ ptext SLIT("*/")

    CmmAssign dest src -> pprAssign dest src

    CmmStore  dest src
183
	| rep == I64 && wordRep /= I64
184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199
	-> ptext SLIT("ASSIGN_Word64") <> 
		parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi

 	| otherwise
	-> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ]
	where
	  rep = cmmExprRep src

    CmmCall (CmmForeignCall fn cconv) results args volatile -> 
	-- Controversial: leave this out for now.
	-- pprUndef fn $$

	pprCall ppr_fn cconv results args volatile
	where
    	ppr_fn = case fn of
		   CmmLit (CmmLabel lbl) -> pprCLabel lbl
200
		   _other -> parens (cCast (pprCFunType cconv results args) fn)
201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222
			-- for a dynamic call, cast the expression to
			-- a function of the right type (we hope).

	-- we #undef a function before calling it: the FFI is supposed to be
	-- an interface specifically to C, not to C+CPP.  For one thing, this
	-- makes the via-C route more compatible with the NCG.  If macros
	-- are being used for optimisation, then inline functions are probably
	-- better anyway.
	pprUndef (CmmLit (CmmLabel lbl)) = 
	   ptext SLIT("#undef") <+> pprCLabel lbl
	pprUndef _ = empty

    CmmCall (CmmPrim op) results args volatile -> 
	pprCall ppr_fn CCallConv results args volatile
	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

223 224 225 226 227 228 229
pprCFunType :: CCallConv -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)] -> SDoc
pprCFunType cconv ress args
  = hcat [
	res_type ress,
	parens (text (ccallConvAttribute cconv) <>  char '*'),
	parens (commafy (map arg_type args))
   ]
230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260
  where
	res_type [] = ptext SLIT("void")
	res_type [(one,hint)] = machRepHintCType (cmmRegRep one) hint

	arg_type (expr,hint) = machRepHintCType (cmmExprRep expr) hint

-- ---------------------------------------------------------------------
-- unconditional branches
pprBranch :: BlockId -> SDoc
pprBranch ident = ptext SLIT("goto") <+> pprBlockId ident <> semi


-- ---------------------------------------------------------------------
-- conditional branches to local labels
pprCondBranch :: CmmExpr -> BlockId -> SDoc
pprCondBranch expr ident 
        = hsep [ ptext SLIT("if") , parens(pprExpr expr) ,
                        ptext SLIT("goto") , (pprBlockId ident) <> semi ]


-- ---------------------------------------------------------------------
-- 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 
261 262
  = let pairs  = [ (ix, ident) | (ix,Just ident) <- zip [0..] maybe_ids ]
	pairs2 = [ (map fst as, snd (head as)) | as <- groupBy sndEq pairs ]
263 264
    in 
        (hang (ptext SLIT("switch") <+> parens ( pprExpr e ) <+> lbrace)
265
                4 (vcat ( map caseify pairs2 )))
266 267 268
        $$ rbrace

  where
269
    sndEq (_,x) (_,y) = x == y
270

271 272 273 274
    -- fall through case
    caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
	where 
	do_fallthrough ix =
275
                 hsep [ ptext SLIT("case") , pprHexVal ix wordRep <> colon ,
276 277 278
                        ptext SLIT("/* fall through */") ]

	final_branch ix = 
279
	        hsep [ ptext SLIT("case") , pprHexVal ix wordRep <> colon ,
280
                       ptext SLIT("goto") , (pprBlockId ident) <> semi ]
281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299

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

-- C Types: the invariant is that the C expression generated by
--
--	pprExpr e
--
-- has a type in C which is also given by
--
--	machRepCType (cmmExprRep e)
--
-- (similar invariants apply to the rest of the pretty printer).

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

300
    CmmLoad e I64 | wordRep /= I64
301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342
	-> ptext SLIT("PK_Word64") <> parens (mkP_ <> pprExpr1 e)

    CmmLoad (CmmReg r) rep 
	| isPtrReg r && rep == wordRep
	-> char '*' <> pprAsPtrReg r

    CmmLoad (CmmRegOff r 0) rep 
	| isPtrReg r && rep == wordRep
	-> char '*' <> pprAsPtrReg r

    CmmLoad (CmmRegOff r off) rep
	| isPtrReg r && rep == wordRep 
	-- ToDo: check that the offset is a word multiple?
	-> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift))

    CmmLoad expr rep ->
	-- the general case:
	char '*' <> parens (cCast (machRepPtrCType rep) expr)

    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

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
343
  = ptext SLIT("mulIntMayOflo") <> parens (commafy (map pprExpr args))
344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366
  where isMulMayOfloOp (MO_U_MulMayOflo _) = True
	isMulMayOfloOp (MO_S_MulMayOflo _) = True
	isMulMayOfloOp _ = False

pprMachOpApp mop args
 = 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
    pprArg e | signedOp mop = cCast (machRepSignedCType (cmmExprRep e)) e
 	     | otherwise    = pprExpr1 e

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

pprLit :: CmmLit -> SDoc
pprLit lit = case lit of
367
    CmmInt i rep      -> pprHexVal i rep
368 369 370
    CmmFloat f rep     -> parens (machRepCType rep) <> (rational f)
    CmmLabel clbl      -> mkW_ <> pprCLabel clbl
    CmmLabelOff clbl i -> mkW_ <> pprCLabel clbl <> char '+' <> int i
371 372 373 374 375 376 377 378
    CmmLabelDiffOff clbl1 clbl2 i
        -- WARNING:
        -- * the lit must occur in the info table clbl2
        -- * clbl1 must be an SRT, a slow entry point or a large bitmap
        -- 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.
        -> mkW_ <> pprCLabel clbl1 <> char '+' <> int i
379 380 381

pprLit1 :: CmmLit -> SDoc
pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)
382
pprLit1 lit@(CmmLabelDiffOff _ _ _) = parens (pprLit lit)
383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521
pprLit1 lit@(CmmFloat _ _)    = parens (pprLit lit)
pprLit1 other = pprLit other

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

pprStatics :: [CmmStatic] -> [SDoc]
pprStatics [] = []
pprStatics (CmmStaticLit (CmmFloat f F32) : rest) 
  = pprLit1 (floatToWord f) : pprStatics rest
pprStatics (CmmStaticLit (CmmFloat f F64) : rest)
  = map pprLit1 (doubleToWords f) ++ pprStatics rest
pprStatics (CmmStaticLit (CmmInt i I64) : rest)
  | machRepByteWidth I32 == wORD_SIZE
#ifdef WORDS_BIGENDIAN
  = pprStatics (CmmStaticLit (CmmInt q I32) : 
		CmmStaticLit (CmmInt r I32) : rest)
#else
  = pprStatics (CmmStaticLit (CmmInt r I32) : 
		CmmStaticLit (CmmInt q I32) : rest)
#endif
  where r = i .&. 0xffffffff
	q = i `shiftR` 32
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)
    CmmAlign i         -> nest 4 (ptext SLIT("/* align */") <+> int i)
    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 '-'
        MO_Eq           _ -> ptext SLIT("==")
        MO_Ne           _ -> ptext SLIT("!=")
        MO_Mul          _ -> char '*'

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

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

        -- Signed comparisons (floating-point comparisons also use these)
        -- & Unsigned comparisons
        MO_S_Ge         _ -> ptext SLIT(">=")
        MO_S_Le         _ -> ptext SLIT("<=")
        MO_S_Gt         _ -> char '>'
        MO_S_Lt         _ -> char '<'

        MO_U_Ge         _ -> ptext SLIT(">=")
        MO_U_Le         _ -> ptext SLIT("<=")
        MO_U_Gt         _ -> char '>'
        MO_U_Lt         _ -> char '<'

        -- 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 '~'
        MO_Shl          _ -> ptext SLIT("<<")
        MO_U_Shr        _ -> ptext SLIT(">>") -- unsigned shift right
        MO_S_Shr        _ -> ptext SLIT(">>") -- signed shift right

-- Conversions.  Some of these will be NOPs.
-- Floating-point conversions use the signed variant.
-- We won't know to generate (void*) casts here, but maybe from
-- context elsewhere

-- noop casts
        MO_U_Conv I8 I8     -> empty
        MO_U_Conv I16 I16   -> empty
        MO_U_Conv I32 I32   -> empty
        MO_U_Conv I64 I64   -> empty
        MO_U_Conv I128 I128 -> empty
        MO_S_Conv I8 I8     -> empty
        MO_S_Conv I16 I16   -> empty
        MO_S_Conv I32 I32   -> empty
        MO_S_Conv I64 I64   -> empty
        MO_S_Conv I128 I128 -> empty

	MO_U_Conv _from to  -> parens (machRepCType to)
	MO_S_Conv _from to  -> parens (machRepSignedCType to)

        _ -> panic "PprC.pprMachOp_for_C: unknown machop"

signedOp :: MachOp -> Bool
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
signedOp (MO_S_Conv _ _) = True
signedOp _ = False

-- ---------------------------------------------------------------------
-- tend to be implemented by foreign calls

pprCallishMachOp_for_C :: CallishMachOp -> SDoc

pprCallishMachOp_for_C mop 
    = case mop of
        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")
ross's avatar
ross committed
522
        MO_F64_Acos -> ptext SLIT("acos")
523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600
        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("pow")
        MO_F32_Sin  -> ptext SLIT("sin")
        MO_F32_Cos  -> ptext SLIT("cos")
        MO_F32_Tan  -> ptext SLIT("tan")
        MO_F32_Sinh -> ptext SLIT("sinh")
        MO_F32_Cosh -> ptext SLIT("cosh")
        MO_F32_Tanh -> ptext SLIT("tanh")
        MO_F32_Asin -> ptext SLIT("asin")
        MO_F32_Acos -> ptext SLIT("acos")
        MO_F32_Atan -> ptext SLIT("atan")
        MO_F32_Log  -> ptext SLIT("log")
        MO_F32_Exp  -> ptext SLIT("exp")
        MO_F32_Sqrt -> ptext SLIT("sqrt")

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

mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc

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


mkFB_, mkFE_ :: SDoc
mkFB_ = ptext SLIT("FB_") -- function code begin
mkFE_ = ptext SLIT("FE_") -- function code end

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

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

mkLI_ = ptext SLIT("(LI_)")       -- StgInt64
mkLW_ = ptext SLIT("(LW_)")       -- StgWord64


-- ---------------------------------------------------------------------
--
-- 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)
   | not (isStrangeTypeReg r1) && not (isStrangeTypeReg r2)
   || isPtrReg r1 && isPtrReg r2
   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ]

-- dest is a reg, rhs is a CmmRegOff
pprAssign r1 (CmmRegOff r2 off)
   | not (isStrangeTypeReg r1) && not (isStrangeTypeReg r2)
   || isPtrReg r1 && isPtrReg r2
   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]
  where
	off1 | isPtrReg r2 = off `shiftR` wordShift
	     | otherwise   = off

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

601 602 603
-- 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+).
604
pprAssign r1 r2
605 606 607 608 609 610
  | isPtrReg r1
  = pprAsPtrReg r1 <> ptext SLIT(" = ") <> mkP_ <> pprExpr1 r2 <> semi
  | Just ty <- strangeRegType r1
  = pprReg r1 <> ptext SLIT(" = ") <> parens ty <> pprExpr1 r2 <> semi
  | otherwise
  = pprReg r1 <> ptext SLIT(" = ") <> pprExpr r2 <> semi
611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644

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

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

-- True if the register has type StgPtr in C, otherwise it has an
-- integer type.  We need to take care with pointer arithmetic on registers
-- with type StgPtr.
isPtrReg :: CmmReg -> Bool
isPtrReg (CmmLocal _) = False
isPtrReg (CmmGlobal r) = isPtrGlobalReg r

isPtrGlobalReg :: GlobalReg -> Bool
isPtrGlobalReg (VanillaReg n) 	= True
isPtrGlobalReg Sp 		= True
isPtrGlobalReg Hp 		= True
isPtrGlobalReg HpLim 		= True
isPtrGlobalReg SpLim 		= True
isPtrGlobalReg _ 		= False

-- True if in C this register doesn't have the type given by 
-- (machRepCType (cmmRegRep reg)), so it has to be cast.
isStrangeTypeReg :: CmmReg -> Bool
isStrangeTypeReg (CmmLocal _) 	= False
isStrangeTypeReg (CmmGlobal g) 	= isStrangeTypeGlobal g

isStrangeTypeGlobal :: GlobalReg -> Bool
isStrangeTypeGlobal CurrentTSO		= True
isStrangeTypeGlobal CurrentNursery 	= True
isStrangeTypeGlobal r 			= isPtrGlobalReg r

645 646 647 648
strangeRegType :: CmmReg -> Maybe SDoc
strangeRegType (CmmGlobal CurrentTSO) = Just (ptext SLIT("struct StgTSO_ *"))
strangeRegType (CmmGlobal CurrentNursery) = Just (ptext SLIT("struct bdescr_ *"))
strangeRegType _ = Nothing
649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699

-- 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
pprAsPtrReg (CmmGlobal (VanillaReg n)) = char 'R' <> int n <> ptext SLIT(".p")
pprAsPtrReg other_reg = pprReg other_reg

pprGlobalReg :: GlobalReg -> SDoc
pprGlobalReg gr = case gr of
    VanillaReg n   -> char 'R' <> int n  <> ptext SLIT(".w")
    FloatReg   n   -> char 'F' <> int n
    DoubleReg  n   -> char 'D' <> int n
    LongReg    n   -> char 'L' <> int n
    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")
    GCEnter1       -> ptext SLIT("stg_gc_enter_1")
    GCFun          -> ptext SLIT("stg_gc_fun")

pprLocalReg :: LocalReg -> SDoc
pprLocalReg (LocalReg uniq _rep) = char '_' <> ppr uniq

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

pprCall :: SDoc -> CCallConv -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)]
	-> Maybe [GlobalReg] -> SDoc

pprCall ppr_fn cconv results args vols
  | not (is_cish cconv)
  = panic "pprForeignCall: unknown calling convention"

  | otherwise
  = save vols $$
    ptext SLIT("CALLER_SAVE_SYSTEM") $$
    hcat [ ppr_results results, ppr_fn, 
	   parens (commafy (map pprArg args)), semi ] $$
    ptext SLIT("CALLER_RESTORE_SYSTEM") $$
    restore vols
  where 
     ppr_results []     = empty
700
     ppr_results [(one,hint)] 
701 702
	 = pprExpr (CmmReg one) <> ptext SLIT(" = ")
		 <> pprUnHint hint (cmmRegRep one)
703 704 705 706 707 708 709 710 711 712
     ppr_results _other = panic "pprCall: multiple results"

     pprArg (expr, PtrHint)
   	= cCast (ptext SLIT("void *")) expr
	-- see comment by machRepHintCType below
     pprArg (expr, SignedHint)
	= cCast (machRepSignedCType (cmmExprRep expr)) expr
     pprArg (expr, _other)
	= pprExpr expr

713 714 715 716
     pprUnHint PtrHint    rep = parens (machRepCType rep)
     pprUnHint SignedHint rep = parens (machRepCType rep)
     pprUnHint _          _   = empty

717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798
     save    = save_restore SLIT("CALLER_SAVE")
     restore = save_restore SLIT("CALLER_RESTORE")

	-- Nothing says "I don't know what's live; save everything"
	-- CALLER_SAVE_USER is defined in ghc/includes/Regs.h
     save_restore txt Nothing     = ptext txt <> ptext SLIT("_USER")
     save_restore txt (Just these) = vcat (map saveRestoreGlobal these)
	where saveRestoreGlobal r = ptext txt <> char '_' <> pprGlobalRegName r

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

is_cish CCallConv   = True
is_cish StdCallConv = True
is_cish _	    = False

-- ---------------------------------------------------------------------
-- Find and print local and external declarations for a list of
-- Cmm statements.
-- 
pprTempAndExternDecls :: [CmmBasicBlock] -> (SDoc{-temps-}, SDoc{-externs-})
pprTempAndExternDecls stmts 
  = (vcat (map pprTempDecl (eltsUFM temps)), 
     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
pprTempDecl l@(LocalReg _uniq rep)
  = 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
  | otherwise		    = 
	hcat [ visibility, label_type (labelType lbl), 
	       lparen, dyn_wrapper (pprCLabel lbl), text ");" ]
 where
  dyn_wrapper d
    | in_srt && labelDynamic lbl = text "DLL_IMPORT_DATA_VAR" <> parens d
    | otherwise			 = d

  label_type CodeLabel = ptext SLIT("F_")
  label_type DataLabel = ptext SLIT("I_")

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


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
799 800
te_Lit (CmmLabelOff l _) = te_lbl l
te_Lit (CmmLabelDiffOff l1 l2 _) = te_lbl l1
801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 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 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977
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
te_Stmt (CmmCall _ rs es _)	= mapM_ (te_Reg.fst) rs >>
				  mapM_ (te_Expr.fst) es
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 (CmmReg r)		= te_Reg r
te_Expr (CmmLoad e _)		= te_Expr e
te_Expr (CmmMachOp _ es) 	= mapM_ te_Expr es
te_Expr (CmmRegOff r _) 	= te_Reg r
te_Expr _ 			= return ()

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

-- 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.
machRepHintCType :: MachRep -> MachHint -> SDoc
machRepHintCType rep PtrHint    = ptext SLIT("void *")
machRepHintCType rep SignedHint = machRepSignedCType rep
machRepHintCType rep _other     = machRepCType rep

machRepPtrCType :: MachRep -> SDoc
machRepPtrCType r | r == wordRep = ptext SLIT("P_")
	          | otherwise    = machRepCType r <> char '*'

machRepCType :: MachRep -> SDoc
machRepCType r | r == wordRep = ptext SLIT("W_")
	       | otherwise    = sized_type
  where sized_type = case r of
			I8	-> ptext SLIT("StgWord8")
			I16	-> ptext SLIT("StgWord16")
			I32	-> ptext SLIT("StgWord32")
			I64	-> ptext SLIT("StgWord64")
			F32	-> ptext SLIT("StgFloat") -- ToDo: correct?
			F64	-> ptext SLIT("StgDouble")
			_  -> panic "machRepCType"

machRepSignedCType :: MachRep -> SDoc
machRepSignedCType r | r == wordRep = ptext SLIT("I_")
                     | otherwise    = sized_type
  where sized_type = case r of
			I8	-> ptext SLIT("StgInt8")
			I16	-> ptext SLIT("StgInt16")
			I32	-> ptext SLIT("StgInt32")
			I64	-> ptext SLIT("StgInt64")
			F32	-> ptext SLIT("StgFloat") -- ToDo: correct?
			F64	-> ptext SLIT("StgDouble")
			_ -> panic "machRepCType"

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

-- Assumes it contains only characters '\0'..'\xFF'!
pprFSInCStyle :: FastString -> SDoc
pprFSInCStyle fs = pprStringInCStyle (unpackFS fs)

pprStringInCStyle :: String -> SDoc
pprStringInCStyle s = doubleQuotes (text (concatMap charToC s))

charToC :: Char -> String
charToC '\"' = "\\\""
charToC '\'' = "\\\'"
charToC '\\' = "\\\\"
charToC c | c >= ' ' && c <= '~' = [c]
          | c > '\xFF' = panic ("charToC "++show c)
          | otherwise = ['\\',
                         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 
  | machRepByteWidth F64 == 2 * wORD_SIZE  = True
  | machRepByteWidth F64 == wORD_SIZE      = False
  | otherwise = panic "big_doubles"

#if __GLASGOW_HASKELL__ >= 504
newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
newFloatArray = newArray_

newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
newDoubleArray = newArray_

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

writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
writeFloatArray = writeArray

writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
writeDoubleArray = writeArray

readIntArray :: STUArray s Int Int -> Int -> ST s Int
readIntArray = readArray

#else

castFloatToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
castFloatToIntArray = return

castDoubleToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
castDoubleToIntArray = return

#endif

-- floats are always 1 word
floatToWord :: Rational -> CmmLit
floatToWord r
  = runST (do
	arr <- newFloatArray ((0::Int),0)
	writeFloatArray arr 0 (fromRational r)
	arr' <- castFloatToIntArray arr
	i <- readIntArray arr' 0
	return (CmmInt (toInteger i) wordRep)
    )

doubleToWords :: Rational -> [CmmLit]
doubleToWords r
  | big_doubles				-- doubles are 2 words
  = runST (do
	arr <- newDoubleArray ((0::Int),1)
	writeDoubleArray arr 0 (fromRational r)
	arr' <- castDoubleToIntArray arr
	i1 <- readIntArray arr' 0
	i2 <- readIntArray arr' 1
	return [ CmmInt (toInteger i1) wordRep
	       , CmmInt (toInteger i2) wordRep
	       ]
    )
  | otherwise				-- doubles are 1 word
  = runST (do
	arr <- newDoubleArray ((0::Int),0)
	writeDoubleArray arr 0 (fromRational r)
	arr' <- castDoubleToIntArray arr
	i <- readIntArray arr' 0
	return [ CmmInt (toInteger i) wordRep ]
    )

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

wordShift :: Int
wordShift = machRepLogWidth wordRep

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

-- Print in C hex format: 0x13fa
978 979 980 981 982
pprHexVal :: Integer -> MachRep -> SDoc
pprHexVal 0 _ = ptext SLIT("0x0")
pprHexVal w rep
  | w < 0     = parens (char '-' <> ptext SLIT("0x") <> go (-w) <> repsuffix rep)
  | otherwise = ptext SLIT("0x") <> go w <> repsuffix rep
983
  where
984 985 986 987 988 989 990
  	-- type suffix for literals:
	-- on 32-bit platforms, add "LL" to 64-bit literals
      repsuffix I64 | wORD_SIZE == 4 = ptext SLIT("LL")
      	-- on 64-bit platforms with 32-bit int, add "L" to 64-bit literals
      repsuffix I64 | cINT_SIZE == 4 = ptext SLIT("L")
      repsuffix _ = empty
      
991 992 993 994 995 996 997
      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'))