PprC.hs 45.8 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
{-# LANGUAGE GADTs #-}
20 21
module PprC (
        writeCs,
dterei's avatar
dterei committed
22
        pprStringInCStyle
23 24
  ) where

25 26
#include "HsVersions.h"

27
-- Cmm stuff
28
import BlockId
29 30
import CLabel
import ForeignCall
31 32 33 34
import Cmm hiding (pprBBlock)
import PprCmm ()
import Hoopl
import CmmUtils
35 36

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

-- The rest
dterei's avatar
dterei committed
47
import Control.Monad.ST
Simon Marlow's avatar
Simon Marlow committed
48 49
import Data.Bits
import Data.Char
dterei's avatar
dterei committed
50
import Data.List
51
import Data.Map (Map)
Simon Marlow's avatar
Simon Marlow committed
52
import Data.Word
dterei's avatar
dterei committed
53 54
import System.IO
import qualified Data.Map as Map
Austin Seipp's avatar
Austin Seipp committed
55 56
import Control.Monad (liftM, ap)
import Control.Applicative (Applicative(..))
57

dterei's avatar
dterei committed
58 59
import Data.Array.Unsafe ( castSTUArray )
import Data.Array.ST hiding ( castSTUArray )
60

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 c) cmms)
67 68
 where
   split_marker
ian@well-typed.com's avatar
ian@well-typed.com committed
69
     | gopt 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 dflags 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 :: RawCmmGroup -> SDoc
pprC tops = vcat $ intersperse blankLine $ map pprTop tops
84 85 86

--
-- top level procs
dterei's avatar
dterei committed
87
--
88
pprTop :: RawCmmDecl -> SDoc
89 90 91
pprTop (CmmProc infos clbl _ graph) =

    (case mapLookup (g_entry graph) infos of
92
       Nothing -> empty
93 94
       Just (Statics info_clbl info_dat) -> pprDataExterns info_dat $$
                                            pprWordArray info_clbl info_dat) $$
95
    (vcat [
dterei's avatar
dterei committed
96 97
           blankLine,
           extern_decls,
98
           (if (externallyVisibleCLabel clbl)
99
                    then mkFN_ else mkIF_) (ppr clbl) <+> lbrace,
100 101
           nest 8 temp_decls,
           nest 8 mkFB_,
102
           vcat (map pprBBlock blocks),
103 104 105 106
           nest 8 mkFE_,
           rbrace ]
    )
  where
107
        blocks = toBlockListEntryFirst graph
108
        (temp_decls, extern_decls) = pprTempAndExternDecls blocks
109 110 111 112 113 114


-- Chunks of static data.

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

115
pprTop (CmmData _section (Statics lbl [CmmString str])) =
116
  hcat [
117
    pprLocalness lbl, ptext (sLit "char "), ppr lbl,
Ian Lynagh's avatar
Ian Lynagh committed
118
    ptext (sLit "[] = "), pprStringInCStyle str, semi
119 120
  ]

121
pprTop (CmmData _section (Statics lbl [CmmUninitialised size])) =
122
  hcat [
123
    pprLocalness lbl, ptext (sLit "char "), ppr lbl,
124 125 126
    brackets (int size), semi
  ]

127 128 129
pprTop (CmmData _section (Statics lbl lits)) =
  pprDataExterns lits $$
  pprWordArray lbl lits
130 131 132 133 134 135 136 137

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

138 139 140 141 142 143
pprBBlock :: CmmBlock -> SDoc
pprBBlock block =
  nest 4 (pprBlockId lbl <> colon) $$
  nest 8 (vcat (map pprStmt (blockToList nodes)) $$ pprStmt last)
 where
  (CmmEntry lbl, nodes, last)  = blockSplit block
144 145

-- --------------------------------------------------------------------------
dterei's avatar
dterei committed
146
-- Info tables. Just arrays of words.
147 148
-- See codeGen/ClosureInfo, and nativeGen/PprMach

149 150
pprWordArray :: CLabel -> [CmmStatic] -> SDoc
pprWordArray lbl ds
151 152
  = sdocWithDynFlags $ \dflags ->
    hcat [ pprLocalness lbl, ptext (sLit "StgWord")
153
         , space, ppr lbl, ptext (sLit "[] = {") ]
154
    $$ nest 8 (commafy (pprStatics dflags ds))
Ian Lynagh's avatar
Ian Lynagh committed
155
    $$ ptext (sLit "};")
156 157 158 159 160

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

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

168
pprStmt :: CmmNode e x -> SDoc
169

170 171 172
pprStmt stmt =
    sdocWithDynFlags $ \dflags ->
    case stmt of
Simon Marlow's avatar
Simon Marlow committed
173
    CmmEntry _ -> empty
dterei's avatar
dterei committed
174
    CmmComment _ -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/")
Simon Marlow's avatar
Simon Marlow committed
175 176 177 178
                          -- 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.
179

180
    CmmAssign dest src -> pprAssign dflags dest src
181 182

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

dterei's avatar
dterei committed
188
        | otherwise
189
        -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ]
dterei's avatar
dterei committed
190
        where
191
          rep = cmmExprType dflags src
192

193
    CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args ->
dterei's avatar
dterei committed
194 195
        fnCall
        where
196 197 198 199 200 201 202
        (res_hints, arg_hints) = foreignTargetHints target
        hresults = zip results res_hints
        hargs    = zip args arg_hints

        ForeignConvention cconv _ _ ret = conv

        cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn)
203

204
        -- See wiki:Commentary/Compiler/Backends/PprC#Prototypes
205
        fnCall =
206
            case fn of
dterei's avatar
dterei committed
207
              CmmLit (CmmLabel lbl)
208
                | StdCallConv <- cconv ->
209
                    pprCall (ppr lbl) cconv hresults hargs
210 211 212 213 214
                        -- 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.
215
                | CmmNeverReturns <- ret ->
216
                    pprCall cast_fn cconv hresults hargs <> semi
217
                | not (isMathFun lbl) ->
218
                    pprForeignCall (ppr lbl) cconv hresults hargs
dterei's avatar
dterei committed
219
              _ ->
220
                    pprCall cast_fn cconv hresults hargs <> semi
dterei's avatar
dterei committed
221
                        -- for a dynamic call, no declaration is necessary.
222

Simon Marlow's avatar
Simon Marlow committed
223 224
    CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty

225
    CmmUnsafeForeignCall target@(PrimTarget op) results args ->
226
        fn_call
227 228 229
      where
        cconv = CCallConv
        fn = pprCallishMachOp_for_C op
230 231 232 233 234

        (res_hints, arg_hints) = foreignTargetHints target
        hresults = zip results res_hints
        hargs    = zip args arg_hints

235
        fn_call
236 237 238 239 240
          -- The mem primops carry an extra alignment arg, must drop it.
          -- We could maybe emit an alignment directive using this info.
          -- We also need to cast mem primops to prevent conflicts with GCC
          -- builtins (see bug #5967).
          | op `elem` [MO_Memcpy, MO_Memset, MO_Memmove]
241 242
          = (ptext (sLit ";EF_(") <> fn <> char ')' <> semi) $$
            pprForeignCall fn cconv hresults (init hargs)
243
          | otherwise
244
          = pprCall fn cconv hresults hargs
245 246

    CmmBranch ident          -> pprBranch ident
247 248
    CmmCondBranch expr yes no -> pprCondBranch expr yes no
    CmmCall { cml_target = expr } -> mkJMP_ (pprExpr expr) <> semi
249 250
    CmmSwitch arg ids        -> sdocWithDynFlags $ \dflags ->
                                pprSwitch dflags arg ids
251

Simon Marlow's avatar
Simon Marlow committed
252 253
    _other -> pprPanic "PprC.pprStmt" (ppr stmt)

254 255 256
type Hinted a = (a, ForeignHint)

pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual]
257 258
               -> SDoc
pprForeignCall fn cconv results args = fn_call
259 260 261 262
  where
    fn_call = braces (
                 pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
              $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
263
              $$ pprCall (text "ghcFunPtr") cconv results args <> semi
264 265 266
             )
    cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn)

267
pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
268
pprCFunType ppr_fn cconv ress args
269 270
  = sdocWithDynFlags $ \dflags ->
    let res_type [] = ptext (sLit "void")
271
        res_type [(one, hint)] = machRepHintCType (localRegType one) hint
dterei's avatar
dterei committed
272
        res_type _ = panic "pprCFunType: only void or 1 return value supported"
273

274
        arg_type (expr, hint) = machRepHintCType (cmmExprType dflags expr) hint
275 276 277
    in res_type ress <+>
       parens (ccallConvAttribute cconv <> ppr_fn) <>
       parens (commafy (map arg_type args))
278 279 280 281

-- ---------------------------------------------------------------------
-- unconditional branches
pprBranch :: BlockId -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
282
pprBranch ident = ptext (sLit "goto") <+> pprBlockId ident <> semi
283 284 285 286


-- ---------------------------------------------------------------------
-- conditional branches to local labels
287 288
pprCondBranch :: CmmExpr -> BlockId -> BlockId -> SDoc
pprCondBranch expr yes no
289
        = hsep [ ptext (sLit "if") , parens(pprExpr expr) ,
290 291
                        ptext (sLit "goto"), pprBlockId yes <> semi,
                        ptext (sLit "else goto"), pprBlockId no <> semi ]
292 293 294 295 296 297 298 299 300 301

-- ---------------------------------------------------------------------
-- 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.
--
302 303
pprSwitch :: DynFlags -> CmmExpr -> [ Maybe BlockId ] -> SDoc
pprSwitch dflags e maybe_ids
304
  = let pairs  = [ (ix, ident) | (ix,Just ident) <- zip [0..] maybe_ids ]
dterei's avatar
dterei committed
305 306
        pairs2 = [ (map fst as, snd (head as)) | as <- groupBy sndEq pairs ]
    in
307
        (hang (ptext (sLit "switch") <+> parens ( pprExpr e ) <+> lbrace)
308
                4 (vcat ( map caseify pairs2 )))
309 310 311
        $$ rbrace

  where
312
    sndEq (_,x) (_,y) = x == y
313

314 315
    -- fall through case
    caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
dterei's avatar
dterei committed
316 317
        where
        do_fallthrough ix =
318
                 hsep [ ptext (sLit "case") , pprHexVal ix (wordWidth dflags) <> colon ,
Ian Lynagh's avatar
Ian Lynagh committed
319
                        ptext (sLit "/* fall through */") ]
320

dterei's avatar
dterei committed
321
        final_branch ix =
322
                hsep [ ptext (sLit "case") , pprHexVal ix (wordWidth dflags) <> colon ,
Ian Lynagh's avatar
Ian Lynagh committed
323
                       ptext (sLit "goto") , (pprBlockId ident) <> semi ]
324

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

327 328 329 330 331 332
-- ---------------------------------------------------------------------
-- Expressions.
--

-- C Types: the invariant is that the C expression generated by
--
dterei's avatar
dterei committed
333
--      pprExpr e
334 335 336
--
-- has a type in C which is also given by
--
dterei's avatar
dterei committed
337
--      machRepCType (cmmExprType e)
338 339 340
--
-- (similar invariants apply to the rest of the pretty printer).

341 342 343
pprExpr :: CmmExpr -> SDoc
pprExpr e = case e of
    CmmLit lit -> pprLit lit
344 345


346
    CmmLoad e ty -> sdocWithDynFlags $ \dflags -> pprLoad dflags e ty
347 348 349 350
    CmmReg reg      -> pprCastReg reg
    CmmRegOff reg 0 -> pprCastReg reg

    CmmRegOff reg i
Simon Marlow's avatar
Simon Marlow committed
351 352
        | i < 0 && negate_ok -> pprRegOff (char '-') (-i)
        | otherwise          -> pprRegOff (char '+') i
353
      where
dterei's avatar
dterei committed
354
        pprRegOff op i' = pprCastReg reg <> op <> int i'
Simon Marlow's avatar
Simon Marlow committed
355 356 357
        negate_ok = negate (fromIntegral i :: Integer) <
                    fromIntegral (maxBound::Int)
                     -- overflow is undefined; see #7620
358

359
    CmmMachOp mop args -> pprMachOpApp mop args
360

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

363

364 365 366
pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc
pprLoad dflags e ty
  | width == W64, wordWidth dflags /= W64
367
  = (if isFloatType ty then ptext (sLit "PK_DBL")
dterei's avatar
dterei committed
368
                       else ptext (sLit "PK_Word64"))
369
    <> parens (mkP_ <> pprExpr1 e)
370

dterei's avatar
dterei committed
371
  | otherwise
372
  = case e of
373
        CmmReg r | isPtrReg r && width == wordWidth dflags && not (isFloatType ty)
dterei's avatar
dterei committed
374
                 -> char '*' <> pprAsPtrReg r
375

376
        CmmRegOff r 0 | isPtrReg r && width == wordWidth dflags && not (isFloatType ty)
dterei's avatar
dterei committed
377
                      -> char '*' <> pprAsPtrReg r
378

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

385
        _other -> cLoad e ty
386 387 388
  where
    width = typeWidth ty

389 390 391 392
pprExpr1 :: CmmExpr -> SDoc
pprExpr1 (CmmLit lit)     = pprLit1 lit
pprExpr1 e@(CmmReg _reg)  = pprExpr e
pprExpr1 other            = parens (pprExpr other)
393 394 395 396

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

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

399
pprMachOpApp op args
400
  | isMulMayOfloOp op
401
  = ptext (sLit "mulIntMayOflo") <> parens (commafy (map pprExpr args))
402
  where isMulMayOfloOp (MO_U_MulMayOflo _) = True
dterei's avatar
dterei committed
403 404
        isMulMayOfloOp (MO_S_MulMayOflo _) = True
        isMulMayOfloOp _ = False
405

406
pprMachOpApp mop args
dterei's avatar
dterei committed
407
  | Just ty <- machOpNeedsCast mop
408
  = ty <> parens (pprMachOpApp' mop args)
409
  | otherwise
410
  = pprMachOpApp' mop args
411 412 413 414 415 416 417 418 419

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

420 421
pprMachOpApp' :: MachOp -> [CmmExpr] -> SDoc
pprMachOpApp' mop args
422 423 424 425 426 427 428 429 430 431
 = 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
432
        -- Cast needed for signed integer ops
433 434 435 436
    pprArg e | signedOp    mop = sdocWithDynFlags $ \dflags ->
                                 cCast (machRep_S_CType (typeWidth (cmmExprType dflags e))) e
             | needsFCasts mop = sdocWithDynFlags $ \dflags ->
                                 cCast (machRep_F_CType (typeWidth (cmmExprType dflags e))) e
437
             | otherwise    = pprExpr1 e
438 439 440 441 442
    needsFCasts (MO_F_Eq _)   = False
    needsFCasts (MO_F_Ne _)   = False
    needsFCasts (MO_F_Neg _)  = True
    needsFCasts (MO_F_Quot _) = True
    needsFCasts mop  = floatComparison mop
443 444 445 446

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

447 448
pprLit :: CmmLit -> SDoc
pprLit lit = case lit of
449
    CmmInt i rep      -> pprHexVal i rep
450

451
    CmmFloat f w       -> parens (machRep_F_CType w) <> str
452 453 454 455 456 457 458 459
        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

460 461
    CmmVec {} -> panic "PprC printing vector literal"

462 463
    CmmBlock bid       -> mkW_ <> pprCLabelAddr (infoTblLbl bid)
    CmmHighStackMark   -> panic "PprC printing high stack mark"
464 465
    CmmLabel clbl      -> mkW_ <> pprCLabelAddr clbl
    CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i
dterei's avatar
dterei committed
466
    CmmLabelDiffOff clbl1 _ i
467
        -- WARNING:
468 469
        --  * the lit must occur in the info table clbl2
        --  * clbl1 must be an SRT, a slow entry point or a large bitmap
470 471
        -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i

dterei's avatar
dterei committed
472
    where
473
        pprCLabelAddr lbl = char '&' <> ppr lbl
474

475 476 477 478 479
pprLit1 :: CmmLit -> SDoc
pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)
pprLit1 lit@(CmmLabelDiffOff _ _ _) = parens (pprLit lit)
pprLit1 lit@(CmmFloat _ _)    = parens (pprLit lit)
pprLit1 other = pprLit other
480 481 482 483

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

484 485 486
pprStatics :: DynFlags -> [CmmStatic] -> [SDoc]
pprStatics _ [] = []
pprStatics dflags (CmmStaticLit (CmmFloat f W32) : rest)
487
  -- floats are padded to a word, see #1852
488
  | wORD_SIZE dflags == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest
489
  = pprLit1 (floatToWord dflags f) : pprStatics dflags rest'
490
  | wORD_SIZE dflags == 4
491
  = pprLit1 (floatToWord dflags f) : pprStatics dflags rest
492
  | otherwise
dterei's avatar
dterei committed
493
  = pprPanic "pprStatics: float" (vcat (map ppr' rest))
494 495
    where ppr' (CmmStaticLit l) = sdocWithDynFlags $ \dflags ->
                                  ppr (cmmLitType dflags l)
dterei's avatar
dterei committed
496
          ppr' _other           = ptext (sLit "bad static!")
497 498 499 500
pprStatics dflags (CmmStaticLit (CmmFloat f W64) : rest)
  = map pprLit1 (doubleToWords dflags f) ++ pprStatics dflags rest
pprStatics dflags (CmmStaticLit (CmmInt i W64) : rest)
  | wordWidth dflags == W32
501 502 503 504 505
  = if wORDS_BIGENDIAN dflags
    then pprStatics dflags (CmmStaticLit (CmmInt q W32) :
                            CmmStaticLit (CmmInt r W32) : rest)
    else pprStatics dflags (CmmStaticLit (CmmInt r W32) :
                            CmmStaticLit (CmmInt q W32) : rest)
506
  where r = i .&. 0xffffffff
dterei's avatar
dterei committed
507
        q = i `shiftR` 32
508 509
pprStatics dflags (CmmStaticLit (CmmInt _ w) : _)
  | w /= wordWidth dflags
510
  = panic "pprStatics: cannot emit a non-word-sized static literal"
511 512 513
pprStatics dflags (CmmStaticLit lit : rest)
  = pprLit1 lit : pprStatics dflags rest
pprStatics _ (other : _)
514
  = pprPanic "pprWord" (pprStatic other)
515

516 517
pprStatic :: CmmStatic -> SDoc
pprStatic s = case s of
518

519
    CmmStaticLit lit   -> nest 4 (pprLit lit)
520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537
    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
538
pprMachOp_for_C mop = case mop of
539 540 541 542

        -- Integer operations
        MO_Add          _ -> char '+'
        MO_Sub          _ -> char '-'
Ian Lynagh's avatar
Ian Lynagh committed
543 544
        MO_Eq           _ -> ptext (sLit "==")
        MO_Ne           _ -> ptext (sLit "!=")
545 546 547 548 549 550 551 552 553
        MO_Mul          _ -> char '*'

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

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

554 555 556 557 558 559 560 561
        -- & 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
562 563
        MO_S_Ge         _ -> ptext (sLit ">=")
        MO_S_Le         _ -> ptext (sLit "<=")
564 565 566
        MO_S_Gt         _ -> char '>'
        MO_S_Lt         _ -> char '<'

567
        -- & Unsigned comparisons
Ian Lynagh's avatar
Ian Lynagh committed
568 569
        MO_U_Ge         _ -> ptext (sLit ">=")
        MO_U_Le         _ -> ptext (sLit "<=")
570 571 572
        MO_U_Gt         _ -> char '>'
        MO_U_Lt         _ -> char '<'

573 574 575 576 577 578 579 580
        -- & 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 '<'

581 582 583 584 585 586
        -- 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
587 588 589
        MO_Shl          _ -> ptext (sLit "<<")
        MO_U_Shr        _ -> ptext (sLit ">>") -- unsigned shift right
        MO_S_Shr        _ -> ptext (sLit ">>") -- signed shift right
590

591 592
-- Conversions.  Some of these will be NOPs, but never those that convert
-- between ints and floats.
593 594 595 596 597
-- Floating-point conversions use the signed variant.
-- We won't know to generate (void*) casts here, but maybe from
-- context elsewhere

-- noop casts
598
        MO_UU_Conv from to | from == to -> empty
599
        MO_UU_Conv _from to -> parens (machRep_U_CType to)
600 601

        MO_SS_Conv from to | from == to -> empty
602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617
        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!")
618

619 620 621 622 623 624 625 626
        MO_V_Insert {}    -> pprTrace "offending mop:"
                                (ptext $ sLit "MO_V_Insert")
                                (panic $ "PprC.pprMachOp_for_C: MO_V_Insert"
                                      ++ " should have been handled earlier!")
        MO_V_Extract {}   -> pprTrace "offending mop:"
                                (ptext $ sLit "MO_V_Extract")
                                (panic $ "PprC.pprMachOp_for_C: MO_V_Extract"
                                      ++ " should have been handled earlier!")
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

        MO_V_Add {}       -> pprTrace "offending mop:"
                                (ptext $ sLit "MO_V_Add")
                                (panic $ "PprC.pprMachOp_for_C: MO_V_Add"
                                      ++ " should have been handled earlier!")
        MO_V_Sub {}       -> pprTrace "offending mop:"
                                (ptext $ sLit "MO_V_Sub")
                                (panic $ "PprC.pprMachOp_for_C: MO_V_Sub"
                                      ++ " should have been handled earlier!")
        MO_V_Mul {}       -> pprTrace "offending mop:"
                                (ptext $ sLit "MO_V_Mul")
                                (panic $ "PprC.pprMachOp_for_C: MO_V_Mul"
                                      ++ " should have been handled earlier!")

        MO_VS_Quot {}     -> pprTrace "offending mop:"
                                (ptext $ sLit "MO_VS_Quot")
                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Quot"
                                      ++ " should have been handled earlier!")
        MO_VS_Rem {}      -> pprTrace "offending mop:"
                                (ptext $ sLit "MO_VS_Rem")
                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Rem"
                                      ++ " should have been handled earlier!")
        MO_VS_Neg {}      -> pprTrace "offending mop:"
                                (ptext $ sLit "MO_VS_Neg")
                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Neg"
                                      ++ " should have been handled earlier!")
653

654 655 656 657 658 659 660 661 662
        MO_VU_Quot {}     -> pprTrace "offending mop:"
                                (ptext $ sLit "MO_VU_Quot")
                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Quot"
                                      ++ " should have been handled earlier!")
        MO_VU_Rem {}      -> pprTrace "offending mop:"
                                (ptext $ sLit "MO_VU_Rem")
                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Rem"
                                      ++ " should have been handled earlier!")

663 664 665 666 667 668 669 670
        MO_VF_Insert {}   -> pprTrace "offending mop:"
                                (ptext $ sLit "MO_VF_Insert")
                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Insert"
                                      ++ " should have been handled earlier!")
        MO_VF_Extract {}  -> pprTrace "offending mop:"
                                (ptext $ sLit "MO_VF_Extract")
                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Extract"
                                      ++ " should have been handled earlier!")
671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692

        MO_VF_Add {}      -> pprTrace "offending mop:"
                                (ptext $ sLit "MO_VF_Add")
                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Add"
                                      ++ " should have been handled earlier!")
        MO_VF_Sub {}      -> pprTrace "offending mop:"
                                (ptext $ sLit "MO_VF_Sub")
                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Sub"
                                      ++ " should have been handled earlier!")
        MO_VF_Neg {}      -> pprTrace "offending mop:"
                                (ptext $ sLit "MO_VF_Neg")
                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Neg"
                                      ++ " should have been handled earlier!")
        MO_VF_Mul {}      -> pprTrace "offending mop:"
                                (ptext $ sLit "MO_VF_Mul")
                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Mul"
                                      ++ " should have been handled earlier!")
        MO_VF_Quot {}     -> pprTrace "offending mop:"
                                (ptext $ sLit "MO_VF_Quot")
                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Quot"
                                      ++ " should have been handled earlier!")

dterei's avatar
dterei committed
693
signedOp :: MachOp -> Bool      -- Argument type(s) are signed ints
dterei's avatar
dterei committed
694 695 696 697 698 699 700 701
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
702 703
signedOp (MO_SS_Conv _ _) = True
signedOp (MO_SF_Conv _ _) = True
dterei's avatar
dterei committed
704
signedOp _                = False
705

706
floatComparison :: MachOp -> Bool  -- comparison between float args
dterei's avatar
dterei committed
707 708 709 710 711 712 713
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
714

715 716 717 718 719
-- ---------------------------------------------------------------------
-- tend to be implemented by foreign calls

pprCallishMachOp_for_C :: CallishMachOp -> SDoc

dterei's avatar
dterei committed
720
pprCallishMachOp_for_C mop
721
    = case mop of
dterei's avatar
dterei committed
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
        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")
748
        MO_WriteBarrier -> ptext (sLit "write_barrier")
dterei's avatar
dterei committed
749 750 751
        MO_Memcpy       -> ptext (sLit "memcpy")
        MO_Memset       -> ptext (sLit "memset")
        MO_Memmove      -> ptext (sLit "memmove")
752
        (MO_BSwap w)    -> ptext (sLit $ bSwapLabel w)
dterei's avatar
dterei committed
753
        (MO_PopCnt w)   -> ptext (sLit $ popCntLabel w)
tibbe's avatar
tibbe committed
754
        (MO_UF_Conv w)  -> ptext (sLit $ word2FloatLabel w)
dterei's avatar
dterei committed
755

Ian Lynagh's avatar
Ian Lynagh committed
756 757 758 759 760 761
        MO_S_QuotRem  {} -> unsupported
        MO_U_QuotRem  {} -> unsupported
        MO_U_QuotRem2 {} -> unsupported
        MO_Add2       {} -> unsupported
        MO_U_Mul2     {} -> unsupported
        MO_Touch         -> unsupported
762 763 764
        (MO_Prefetch_Data _ ) -> unsupported
        --- we could support prefetch via "__builtin_prefetch"
        --- Not adding it for now
765 766
    where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop
                            ++ " not supported!")
767 768 769 770 771 772 773

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

mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc

Ian Lynagh's avatar
Ian Lynagh committed
774 775 776
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
777 778 779


mkFB_, mkFE_ :: SDoc
Ian Lynagh's avatar
Ian Lynagh committed
780 781
mkFB_ = ptext (sLit "FB_") -- function code begin
mkFE_ = ptext (sLit "FE_") -- function code end
782 783 784

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

Ian Lynagh's avatar
Ian Lynagh committed
787 788 789
mkC_  = ptext (sLit "(C_)")        -- StgChar
mkW_  = ptext (sLit "(W_)")        -- StgWord
mkP_  = ptext (sLit "(P_)")        -- StgWord*
790 791 792 793 794 795 796

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

-- dest is a reg, rhs is a reg
800
pprAssign _ r1 (CmmReg r2)
801
   | isPtrReg r1 && isPtrReg r2
802 803 804
   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ]

-- dest is a reg, rhs is a CmmRegOff
805
pprAssign dflags r1 (CmmRegOff r2 off)
806
   | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE dflags == 0)
807 808
   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]
  where
809
        off1 = off `shiftR` wordShift dflags
810

dterei's avatar
dterei committed
811 812
        (op,off') | off >= 0  = (char '+', off1)
                  | otherwise = (char '-', -off1)
813

814 815 816
-- 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+).
817
pprAssign _ r1 r2
818 819 820
  | isFixedPtrReg r1             = mkAssign (mkP_ <> pprExpr1 r2)
  | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2)
  | otherwise                    = mkAssign (pprExpr r2)
Ian Lynagh's avatar
Ian Lynagh committed
821
    where mkAssign x = if r1 == CmmGlobal BaseReg
Ian Lynagh's avatar
Ian Lynagh committed
822 823
                       then ptext (sLit "ASSIGN_BaseReg") <> parens x <> semi
                       else pprReg r1 <> ptext (sLit " = ") <> x <> semi
824 825 826 827

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

dterei's avatar
dterei committed
828
pprCastReg :: CmmReg -> SDoc
829 830 831 832
pprCastReg reg
   | isStrangeTypeReg reg = mkW_ <> pprReg reg
   | otherwise            = pprReg reg

833 834 835 836 837 838
-- 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
839

840
-- True if (pprAsPtrReg reg) will give an expression with type StgPtr
841 842 843
-- 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.
844
isPtrReg :: CmmReg -> Bool
dterei's avatar
dterei committed
845 846 847 848
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
849 850 851

-- True if this global reg has type StgPtr
isFixedPtrGlobalReg :: GlobalReg -> Bool
dterei's avatar
dterei committed
852 853 854 855 856
isFixedPtrGlobalReg Sp    = True
isFixedPtrGlobalReg Hp    = True
isFixedPtrGlobalReg HpLim = True
isFixedPtrGlobalReg SpLim = True
isFixedPtrGlobalReg _     = False
857

dterei's avatar
dterei committed
858
-- True if in C this register doesn't have the type given by
859
-- (machRepCType (cmmRegType reg)), so it has to be cast.
860
isStrangeTypeReg :: CmmReg -> Bool
dterei's avatar
dterei committed
861 862
isStrangeTypeReg (CmmLocal _)   = False
isStrangeTypeReg (CmmGlobal g)  = isStrangeTypeGlobal g
863 864

isStrangeTypeGlobal :: GlobalReg -> Bool
865
isStrangeTypeGlobal CCCS                = True
dterei's avatar
dterei committed
866 867 868 869
isStrangeTypeGlobal CurrentTSO          = True
isStrangeTypeGlobal CurrentNursery      = True
isStrangeTypeGlobal BaseReg             = True
isStrangeTypeGlobal r                   = isFixedPtrGlobalReg r
870

871
strangeRegType :: CmmReg -> Maybe SDoc
872
strangeRegType (CmmGlobal CCCS) = Just (ptext (sLit "struct CostCentreStack_ *"))
Ian Lynagh's avatar
Ian Lynagh committed
873 874 875
strangeRegType (CmmGlobal CurrentTSO) = Just (ptext (sLit "struct StgTSO_ *"))
strangeRegType (CmmGlobal CurrentNursery) = Just (ptext (sLit "struct bdescr_ *"))
strangeRegType (CmmGlobal BaseReg) = Just (ptext (sLit "struct StgRegTable_ *"))
876
strangeRegType _ = Nothing
877 878 879 880 881 882