PprC.hs 40.5 KB
Newer Older
1 2 3 4
-----------------------------------------------------------------------------
--
-- Pretty-printing of Cmm as C, suitable for feeding gcc
--
Simon Marlow's avatar
Simon Marlow committed
5
-- (c) The University of Glasgow 2004-2006
6 7 8
--
-- Print Cmm as real C, for -fvia-C
--
9 10
-- See wiki:Commentary/Compiler/Backends/PprC
--
11 12 13 14
-- 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.
--
dterei's avatar
dterei committed
15 16 17
-- This code generator is only supported in unregisterised mode.
--
-----------------------------------------------------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
18

19 20
module PprC (
        writeCs,
dterei's avatar
dterei committed
21
        pprStringInCStyle
22 23
  ) where

24 25
#include "HsVersions.h"

26
-- Cmm stuff
27
import BlockId
28 29
import CLabel
import ForeignCall
dterei's avatar
dterei committed
30 31
import OldCmm
import OldPprCmm ()
32 33

-- Utils
dterei's avatar
dterei committed
34 35
import Constants
import CPrim
Simon Marlow's avatar
Simon Marlow committed
36
import DynFlags
37 38
import FastString
import Outputable
39
import Platform
dterei's avatar
dterei committed
40 41
import UniqSet
import Unique
42
import Util
43 44

-- The rest
dterei's avatar
dterei committed
45
import Control.Monad.ST
Simon Marlow's avatar
Simon Marlow committed
46 47
import Data.Bits
import Data.Char
dterei's avatar
dterei committed
48
import Data.List
49
import Data.Map (Map)
Simon Marlow's avatar
Simon Marlow committed
50
import Data.Word
dterei's avatar
dterei committed
51 52
import System.IO
import qualified Data.Map as Map
53

54
#if __GLASGOW_HASKELL__ >= 703
dterei's avatar
dterei committed
55 56
import Data.Array.Unsafe ( castSTUArray )
import Data.Array.ST hiding ( castSTUArray )
57
#else
58
import Data.Array.ST
59 60
#endif

61 62 63
-- --------------------------------------------------------------------------
-- Top level

Simon Peyton Jones's avatar
Simon Peyton Jones committed
64
pprCs :: DynFlags -> [RawCmmGroup] -> SDoc
65
pprCs dflags cmms
66
 = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC (targetPlatform dflags) c) cmms)
67 68
 where
   split_marker
Ian Lynagh's avatar
Ian Lynagh committed
69
     | dopt Opt_SplitObjs dflags = ptext (sLit "__STG_SPLIT_MARKER")
dterei's avatar
dterei committed
70
     | otherwise                 = empty
71

Simon Peyton Jones's avatar
Simon Peyton Jones committed
72
writeCs :: DynFlags -> Handle -> [RawCmmGroup] -> IO ()
dterei's avatar
dterei committed
73
writeCs dflags handle cmms
74
  = printForC handle (pprCs dflags cmms)
75 76 77 78 79 80 81

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

82 83
pprC :: Platform -> RawCmmGroup -> SDoc
pprC platform tops = vcat $ intersperse blankLine $ map (pprTop platform) tops
84 85 86

--
-- top level procs
dterei's avatar
dterei committed
87
--
88 89
pprTop :: Platform -> RawCmmDecl -> SDoc
pprTop platform (CmmProc mb_info clbl (ListGraph blocks)) =
90 91
    (case mb_info of
       Nothing -> empty
92 93
       Just (Statics info_clbl info_dat) -> pprDataExterns platform info_dat $$
                                            pprWordArray platform info_clbl info_dat) $$
94
    (vcat [
dterei's avatar
dterei committed
95 96
           blankLine,
           extern_decls,
97
           (if (externallyVisibleCLabel clbl)
98
                    then mkFN_ else mkIF_) (pprCLabel platform clbl) <+> lbrace,
99 100
           nest 8 temp_decls,
           nest 8 mkFB_,
101 102 103 104
           case blocks of
               [] -> empty
               -- the first block doesn't get a label:
               (BasicBlock _ stmts : rest) ->
105 106
                    nest 8 (vcat (map (pprStmt platform) stmts)) $$
                       vcat (map (pprBBlock platform) rest),
107 108 109 110
           nest 8 mkFE_,
           rbrace ]
    )
  where
111
        (temp_decls, extern_decls) = pprTempAndExternDecls platform blocks
112 113 114 115 116 117


-- Chunks of static data.

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

118
pprTop platform (CmmData _section (Statics lbl [CmmString str])) =
119
  hcat [
120
    pprLocalness lbl, ptext (sLit "char "), pprCLabel platform lbl,
Ian Lynagh's avatar
Ian Lynagh committed
121
    ptext (sLit "[] = "), pprStringInCStyle str, semi
122 123
  ]

124
pprTop platform (CmmData _section (Statics lbl [CmmUninitialised size])) =
125
  hcat [
126
    pprLocalness lbl, ptext (sLit "char "), pprCLabel platform lbl,
127 128 129
    brackets (int size), semi
  ]

130 131 132
pprTop platform (CmmData _section (Statics lbl lits)) =
  pprDataExterns platform lits $$
  pprWordArray platform lbl lits
133 134 135 136 137 138 139 140

-- --------------------------------------------------------------------------
-- 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.
--

141 142
pprBBlock :: Platform -> CmmBasicBlock -> SDoc
pprBBlock platform (BasicBlock lbl stmts) =
143
    if null stmts then
dterei's avatar
dterei committed
144
        pprTrace "pprC.pprBBlock: curious empty code block for"
145
                        (pprBlockId lbl) empty
dterei's avatar
dterei committed
146
    else
147
        nest 4 (pprBlockId lbl <> colon) $$
148
        nest 8 (vcat (map (pprStmt platform) stmts))
149 150

-- --------------------------------------------------------------------------
dterei's avatar
dterei committed
151
-- Info tables. Just arrays of words.
152 153
-- See codeGen/ClosureInfo, and nativeGen/PprMach

154 155
pprWordArray :: Platform -> CLabel -> [CmmStatic] -> SDoc
pprWordArray platform lbl ds
Ian Lynagh's avatar
Ian Lynagh committed
156
  = hcat [ pprLocalness lbl, ptext (sLit "StgWord")
dterei's avatar
dterei committed
157
         , space, pprCLabel platform lbl, ptext (sLit "[] = {") ]
158
    $$ nest 8 (commafy (pprStatics platform ds))
Ian Lynagh's avatar
Ian Lynagh committed
159
    $$ ptext (sLit "};")
160 161 162 163 164

--
-- has to be static, if it isn't globally visible
--
pprLocalness :: CLabel -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
165
pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext (sLit "static ")
166 167 168 169 170 171
                 | otherwise = empty

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

172
pprStmt :: Platform -> CmmStmt -> SDoc
173

174
pprStmt platform stmt = case stmt of
dterei's avatar
dterei committed
175
    CmmReturn    -> panic "pprStmt: return statement should have been cps'd away"
176
    CmmNop       -> empty
dterei's avatar
dterei committed
177
    CmmComment _ -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/")
Simon Marlow's avatar
Simon Marlow committed
178 179 180 181
                          -- XXX if the string contains "*/", we need to fix it
                          -- XXX we probably want to emit these comments when
                          -- some debugging option is on.  They can get quite
                          -- large.
182

183
    CmmAssign dest src -> pprAssign platform dest src
184 185

    CmmStore  dest src
dterei's avatar
dterei committed
186 187 188 189
        | typeWidth rep == W64 && wordWidth /= W64
        -> (if isFloatType rep then ptext (sLit "ASSIGN_DBL")
                               else ptext (sLit ("ASSIGN_Word64"))) <>
           parens (mkP_ <> pprExpr1 platform dest <> comma <> pprExpr platform src) <> semi
190

dterei's avatar
dterei committed
191 192 193 194
        | otherwise
        -> hsep [ pprExpr platform (CmmLoad dest rep), equals, pprExpr platform src <> semi ]
        where
          rep = cmmExprType src
195

196
    CmmCall (CmmCallee fn cconv) results args ret ->
197
        maybe_proto $$
dterei's avatar
dterei committed
198 199
        fnCall
        where
200
        cast_fn = parens (cCast platform (pprCFunType (char '*') cconv results args) fn)
201

dterei's avatar
dterei committed
202 203
        real_fun_proto lbl = char ';' <>
                        pprCFunType (pprCLabel platform lbl) cconv results args <>
204 205
                        noreturn_attr <> semi

206
        fun_proto lbl = ptext (sLit ";EF_(") <>
207
                         pprCLabel platform lbl <> char ')' <> semi
208 209 210 211

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

213
        -- See wiki:Commentary/Compiler/Backends/PprC#Prototypes
dterei's avatar
dterei committed
214
        (maybe_proto, fnCall) =
215
            case fn of
dterei's avatar
dterei committed
216
              CmmLit (CmmLabel lbl)
217
                | StdCallConv <- cconv ->
218
                    let myCall = pprCall platform (pprCLabel platform lbl) cconv results args
219
                    in (real_fun_proto lbl, myCall)
220 221 222 223 224
                        -- 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.
225
                | CmmNeverReturns <- ret ->
226
                    let myCall = pprCall platform (pprCLabel platform lbl) cconv results args
227
                    in (real_fun_proto lbl, myCall)
228
                | not (isMathFun lbl) ->
229 230 231
                    let myCall = braces (
                                     pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
                                  $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
232
                                  $$ pprCall platform (text "ghcFunPtr") cconv results args <> semi
233 234
                                 )
                    in (fun_proto lbl, myCall)
dterei's avatar
dterei committed
235
              _ ->
236
                   (empty {- no proto -},
237
                    pprCall platform cast_fn cconv results args <> semi)
dterei's avatar
dterei committed
238
                        -- for a dynamic call, no declaration is necessary.
239

Ian Lynagh's avatar
Ian Lynagh committed
240 241
    CmmCall (CmmPrim _ (Just mkStmts)) results args _ret ->
        vcat $ map (pprStmt platform) (mkStmts results args)
242

Ian Lynagh's avatar
Ian Lynagh committed
243
    CmmCall (CmmPrim op _) results args _ret ->
244
        pprCall platform ppr_fn CCallConv results args'
dterei's avatar
dterei committed
245 246 247 248 249
        where
        ppr_fn = pprCallishMachOp_for_C op
        -- The mem primops carry an extra alignment arg, must drop it.
        -- We could maybe emit an alignment directive using this info.
        args'  | op == MO_Memcpy || op == MO_Memset || op == MO_Memmove = init args
250
               | otherwise = args
251 252

    CmmBranch ident          -> pprBranch ident
253
    CmmCondBranch expr ident -> pprCondBranch platform expr ident
254
    CmmJump lbl _            -> mkJMP_(pprExpr platform lbl) <> semi
255
    CmmSwitch arg ids        -> pprSwitch platform arg ids
256

257
pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc
258 259
pprCFunType ppr_fn cconv ress args
  = res_type ress <+>
Ian Lynagh's avatar
Ian Lynagh committed
260
    parens (ccallConvAttribute cconv <> ppr_fn) <>
261
    parens (commafy (map arg_type args))
262
  where
dterei's avatar
dterei committed
263 264 265
        res_type [] = ptext (sLit "void")
        res_type [CmmHinted one hint] = machRepHintCType (localRegType one) hint
        res_type _ = panic "pprCFunType: only void or 1 return value supported"
266

dterei's avatar
dterei committed
267
        arg_type (CmmHinted expr hint) = machRepHintCType (cmmExprType expr) hint
268 269 270 271

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


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


-- ---------------------------------------------------------------------
-- 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.
--
292
pprSwitch :: Platform -> CmmExpr -> [ Maybe BlockId ] -> SDoc
dterei's avatar
dterei committed
293
pprSwitch platform e maybe_ids
294
  = let pairs  = [ (ix, ident) | (ix,Just ident) <- zip [0..] maybe_ids ]
dterei's avatar
dterei committed
295 296
        pairs2 = [ (map fst as, snd (head as)) | as <- groupBy sndEq pairs ]
    in
297
        (hang (ptext (sLit "switch") <+> parens ( pprExpr platform e ) <+> lbrace)
298
                4 (vcat ( map caseify pairs2 )))
299 300 301
        $$ rbrace

  where
302
    sndEq (_,x) (_,y) = x == y
303

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

dterei's avatar
dterei committed
311 312
        final_branch ix =
                hsep [ ptext (sLit "case") , pprHexVal ix wordWidth <> colon ,
Ian Lynagh's avatar
Ian Lynagh committed
313
                       ptext (sLit "goto") , (pprBlockId ident) <> semi ]
314

dterei's avatar
dterei committed
315 316
    caseify (_     , _    ) = panic "pprSwtich: swtich with no cases!"

317 318 319 320 321 322
-- ---------------------------------------------------------------------
-- Expressions.
--

-- C Types: the invariant is that the C expression generated by
--
dterei's avatar
dterei committed
323
--      pprExpr e
324 325 326
--
-- has a type in C which is also given by
--
dterei's avatar
dterei committed
327
--      machRepCType (cmmExprType e)
328 329 330
--
-- (similar invariants apply to the rest of the pretty printer).

331 332 333
pprExpr :: Platform -> CmmExpr -> SDoc
pprExpr platform e = case e of
    CmmLit lit -> pprLit platform lit
334 335


336
    CmmLoad e ty -> pprLoad platform e ty
337 338 339 340
    CmmReg reg      -> pprCastReg reg
    CmmRegOff reg 0 -> pprCastReg reg

    CmmRegOff reg i
dterei's avatar
dterei committed
341 342
        | i >  0    -> pprRegOff (char '+') i
        | otherwise -> pprRegOff (char '-') (-i)
343
      where
dterei's avatar
dterei committed
344
        pprRegOff op i' = pprCastReg reg <> op <> int i'
345

346
    CmmMachOp mop args -> pprMachOpApp platform mop args
347

dterei's avatar
dterei committed
348 349
    CmmStackSlot _ _   -> panic "pprExpr: CmmStackSlot not supported!"

350

351 352
pprLoad :: Platform -> CmmExpr -> CmmType -> SDoc
pprLoad platform e ty
353 354
  | width == W64, wordWidth /= W64
  = (if isFloatType ty then ptext (sLit "PK_DBL")
dterei's avatar
dterei committed
355
                       else ptext (sLit "PK_Word64"))
356
    <> parens (mkP_ <> pprExpr1 platform e)
357

dterei's avatar
dterei committed
358
  | otherwise
359
  = case e of
dterei's avatar
dterei committed
360 361
        CmmReg r | isPtrReg r && width == wordWidth && not (isFloatType ty)
                 -> char '*' <> pprAsPtrReg r
362

dterei's avatar
dterei committed
363 364
        CmmRegOff r 0 | isPtrReg r && width == wordWidth && not (isFloatType ty)
                      -> char '*' <> pprAsPtrReg r
365

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

dterei's avatar
dterei committed
372
        _other -> cLoad platform e ty
373 374 375
  where
    width = typeWidth ty

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

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

384
pprMachOpApp :: Platform -> MachOp -> [CmmExpr] -> SDoc
385

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

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

-- 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

407 408
pprMachOpApp' :: Platform -> MachOp -> [CmmExpr] -> SDoc
pprMachOpApp' platform mop args
409 410 411 412 413 414 415 416 417 418
 = 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
dterei's avatar
dterei committed
419
        -- Cast needed for signed integer ops
420 421
    pprArg e | signedOp    mop = cCast platform (machRep_S_CType (typeWidth (cmmExprType e))) e
             | needsFCasts mop = cCast platform (machRep_F_CType (typeWidth (cmmExprType e))) e
dterei's avatar
dterei committed
422
             | otherwise    = pprExpr1 platform e
423 424 425 426 427
    needsFCasts (MO_F_Eq _)   = False
    needsFCasts (MO_F_Ne _)   = False
    needsFCasts (MO_F_Neg _)  = True
    needsFCasts (MO_F_Quot _) = True
    needsFCasts mop  = floatComparison mop
428 429 430 431

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

432 433
pprLit :: Platform -> CmmLit -> SDoc
pprLit platform lit = case lit of
434
    CmmInt i rep      -> pprHexVal i rep
435

436
    CmmFloat f w       -> parens (machRep_F_CType w) <> str
437 438 439 440 441 442 443 444
        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

445 446
    CmmBlock bid       -> mkW_ <> pprCLabelAddr (infoTblLbl bid)
    CmmHighStackMark   -> panic "PprC printing high stack mark"
447 448
    CmmLabel clbl      -> mkW_ <> pprCLabelAddr clbl
    CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i
dterei's avatar
dterei committed
449
    CmmLabelDiffOff clbl1 _ i
450
        -- WARNING:
451 452
        --  * the lit must occur in the info table clbl2
        --  * clbl1 must be an SRT, a slow entry point or a large bitmap
453 454
        -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i

dterei's avatar
dterei committed
455
    where
456
        pprCLabelAddr lbl = char '&' <> pprCLabel platform lbl
457

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

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

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

500 501
pprStatic :: Platform -> CmmStatic -> SDoc
pprStatic platform s = case s of
502

503
    CmmStaticLit lit   -> nest 4 (pprLit platform lit)
504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521
    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

dterei's avatar
dterei committed
522
pprMachOp_for_C mop = case mop of
523 524 525 526

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

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

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

538 539 540 541 542 543 544 545
        -- & 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
546 547
        MO_S_Ge         _ -> ptext (sLit ">=")
        MO_S_Le         _ -> ptext (sLit "<=")
548 549 550
        MO_S_Gt         _ -> char '>'
        MO_S_Lt         _ -> char '<'

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

557 558 559 560 561 562 563 564
        -- & 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 '<'

565 566 567 568 569 570
        -- 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
571 572 573
        MO_Shl          _ -> ptext (sLit "<<")
        MO_U_Shr        _ -> ptext (sLit ">>") -- unsigned shift right
        MO_S_Shr        _ -> ptext (sLit ">>") -- signed shift right
574

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

-- noop casts
582
        MO_UU_Conv from to | from == to -> empty
583
        MO_UU_Conv _from to -> parens (machRep_U_CType to)
584 585

        MO_SS_Conv from to | from == to -> empty
586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601
        MO_SS_Conv _from to -> parens (machRep_S_CType to)

        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)
        
        MO_S_MulMayOflo _ -> pprTrace "offending mop:"
                                (ptext $ sLit "MO_S_MulMayOflo")
                                (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo"
                                      ++ " should have been handled earlier!")
        MO_U_MulMayOflo _ -> pprTrace "offending mop:"
                                (ptext $ sLit "MO_U_MulMayOflo")
                                (panic $ "PprC.pprMachOp_for_C: MO_U_MulMayOflo"
                                      ++ " should have been handled earlier!")
602

dterei's avatar
dterei committed
603
signedOp :: MachOp -> Bool      -- Argument type(s) are signed ints
dterei's avatar
dterei committed
604 605 606 607 608 609 610 611
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
612 613
signedOp (MO_SS_Conv _ _) = True
signedOp (MO_SF_Conv _ _) = True
dterei's avatar
dterei committed
614
signedOp _                = False
615

616
floatComparison :: MachOp -> Bool  -- comparison between float args
dterei's avatar
dterei committed
617 618 619 620 621 622 623
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
624

625 626 627 628 629
-- ---------------------------------------------------------------------
-- tend to be implemented by foreign calls

pprCallishMachOp_for_C :: CallishMachOp -> SDoc

dterei's avatar
dterei committed
630
pprCallishMachOp_for_C mop
631
    = case mop of
dterei's avatar
dterei committed
632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657
        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")
658
        MO_WriteBarrier -> ptext (sLit "write_barrier")
dterei's avatar
dterei committed
659 660 661
        MO_Memcpy       -> ptext (sLit "memcpy")
        MO_Memset       -> ptext (sLit "memset")
        MO_Memmove      -> ptext (sLit "memmove")
dterei's avatar
dterei committed
662 663
        (MO_PopCnt w)   -> ptext (sLit $ popCntLabel w)

664
        MO_S_QuotRem {} -> unsupported
665
        MO_U_QuotRem {} -> unsupported
Ian Lynagh's avatar
Ian Lynagh committed
666
        MO_Add2      {} -> unsupported
Ian Lynagh's avatar
Ian Lynagh committed
667
        MO_U_Mul2    {} -> unsupported
668 669 670
        MO_Touch        -> unsupported
    where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop
                            ++ " not supported!")
671 672 673 674 675 676 677

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

mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc

Ian Lynagh's avatar
Ian Lynagh committed
678 679 680
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
681 682 683


mkFB_, mkFE_ :: SDoc
Ian Lynagh's avatar
Ian Lynagh committed
684 685
mkFB_ = ptext (sLit "FB_") -- function code begin
mkFE_ = ptext (sLit "FE_") -- function code end
686 687 688

-- from includes/Stg.h
--
Simon Marlow's avatar
Simon Marlow committed
689
mkC_,mkW_,mkP_ :: SDoc
690

Ian Lynagh's avatar
Ian Lynagh committed
691 692 693
mkC_  = ptext (sLit "(C_)")        -- StgChar
mkW_  = ptext (sLit "(W_)")        -- StgWord
mkP_  = ptext (sLit "(P_)")        -- StgWord*
694 695 696 697 698 699 700

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

-- dest is a reg, rhs is a reg
704
pprAssign _ r1 (CmmReg r2)
705
   | isPtrReg r1 && isPtrReg r2
706 707 708
   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ]

-- dest is a reg, rhs is a CmmRegOff
709
pprAssign _ r1 (CmmRegOff r2 off)
710
   | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE == 0)
711 712
   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]
  where
dterei's avatar
dterei committed
713
        off1 = off `shiftR` wordShift
714

dterei's avatar
dterei committed
715 716
        (op,off') | off >= 0  = (char '+', off1)
                  | otherwise = (char '-', -off1)
717

718 719 720
-- 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+).
721 722 723 724
pprAssign platform r1 r2
  | isFixedPtrReg r1             = mkAssign (mkP_ <> pprExpr1 platform r2)
  | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 platform r2)
  | otherwise                    = mkAssign (pprExpr platform r2)
Ian Lynagh's avatar
Ian Lynagh committed
725
    where mkAssign x = if r1 == CmmGlobal BaseReg
Ian Lynagh's avatar
Ian Lynagh committed
726 727
                       then ptext (sLit "ASSIGN_BaseReg") <> parens x <> semi
                       else pprReg r1 <> ptext (sLit " = ") <> x <> semi
728 729 730 731

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

dterei's avatar
dterei committed
732
pprCastReg :: CmmReg -> SDoc
733 734 735 736
pprCastReg reg
   | isStrangeTypeReg reg = mkW_ <> pprReg reg
   | otherwise            = pprReg reg

737 738 739 740 741 742
-- 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
743

744
-- True if (pprAsPtrReg reg) will give an expression with type StgPtr
745 746 747
-- 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.
748
isPtrReg :: CmmReg -> Bool
dterei's avatar
dterei committed
749 750 751 752
isPtrReg (CmmLocal _)                         = False
isPtrReg (CmmGlobal (VanillaReg _ VGcPtr))    = True  -- if we print via pprAsPtrReg
isPtrReg (CmmGlobal (VanillaReg _ VNonGcPtr)) = False -- if we print via pprAsPtrReg
isPtrReg (CmmGlobal reg)                      = isFixedPtrGlobalReg reg
753 754 755

-- True if this global reg has type StgPtr
isFixedPtrGlobalReg :: GlobalReg -> Bool
dterei's avatar
dterei committed
756 757 758 759 760
isFixedPtrGlobalReg Sp    = True
isFixedPtrGlobalReg Hp    = True
isFixedPtrGlobalReg HpLim = True
isFixedPtrGlobalReg SpLim = True
isFixedPtrGlobalReg _     = False
761

dterei's avatar
dterei committed
762
-- True if in C this register doesn't have the type given by
763
-- (machRepCType (cmmRegType reg)), so it has to be cast.
764
isStrangeTypeReg :: CmmReg -> Bool
dterei's avatar
dterei committed
765 766
isStrangeTypeReg (CmmLocal _)   = False
isStrangeTypeReg (CmmGlobal g)  = isStrangeTypeGlobal g
767 768

isStrangeTypeGlobal :: GlobalReg -> Bool
769
isStrangeTypeGlobal CCCS                = True
dterei's avatar
dterei committed
770 771 772 773
isStrangeTypeGlobal CurrentTSO          = True
isStrangeTypeGlobal CurrentNursery      = True
isStrangeTypeGlobal BaseReg             = True
isStrangeTypeGlobal r                   = isFixedPtrGlobalReg r
774

775
strangeRegType :: CmmReg -> Maybe SDoc
776
strangeRegType (CmmGlobal CCCS) = Just (ptext (sLit "struct CostCentreStack_ *"))
Ian Lynagh's avatar
Ian Lynagh committed
777 778 779
strangeRegType (CmmGlobal CurrentTSO) = Just (ptext (sLit "struct StgTSO_ *"))
strangeRegType (CmmGlobal CurrentNursery) = Just (ptext (sLit "struct bdescr_ *"))
strangeRegType (CmmGlobal BaseReg) = Just (ptext (sLit "struct StgRegTable_ *"))
780
strangeRegType _ = Nothing
781 782 783 784 785 786 787

-- pprReg just prints the register name.
--
pprReg :: CmmReg -> SDoc
pprReg r = case r of
        CmmLocal  local  -> pprLocalReg local
        CmmGlobal global -> pprGlobalReg global
dterei's avatar
dterei committed
788

789
pprAsPtrReg :: CmmReg -> SDoc
dterei's avatar
dterei committed
790
pprAsPtrReg (CmmGlobal (VanillaReg n gcp))
791
  = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> ptext (sLit ".p")
792 793 794 795
pprAsPtrReg other_reg = pprReg other_reg

pprGlobalReg :: GlobalReg -> SDoc
pprGlobalReg gr = case gr of
796
    VanillaReg n _ -> char 'R' <> int n  <> ptext (sLit ".w")
dterei's avatar
dterei committed
797 798 799
        -- pprGlobalReg prints a VanillaReg as a .w regardless
        -- Example:     R1.w = R1.w & (-0x8UL);
        --              JMP_(*R1.p);
800 801 802
    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
803 804 805 806
    Sp             -> ptext (sLit "Sp")
    SpLim          -> ptext (sLit "SpLim")
    Hp             -> ptext (sLit "Hp")
    HpLim          -> ptext (sLit "HpLim")
807
    CCCS           -> ptext (sLit "CCCS")
Ian Lynagh's avatar
Ian Lynagh committed
808 809 810 811
    CurrentTSO     -> ptext (sLit "CurrentTSO")
    CurrentNursery -> ptext (sLit "CurrentNursery")
    HpAlloc        -> ptext (sLit "HpAlloc")
    BaseReg        -> ptext (sLit "BaseReg")
812
    EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info")
Ian Lynagh's avatar
Ian Lynagh committed
813 814
    GCEnter1       -> ptext (sLit "stg_gc_enter_1")
    GCFun          -> ptext (sLit "stg_gc_fun")
dterei's avatar
dterei committed
815
    other          -> panic $ "pprGlobalReg: Unsupported register: " ++ show other
816 817

pprLocalReg :: LocalReg -> SDoc
818
pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq
819 820 821 822

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

823
pprCall :: Platform -> SDoc -> CCallConv