compiler/cmm/PprCmm.hs

   1 ----------------------------------------------------------------------------
   2 --
   3 -- Pretty-printing of Cmm as (a superset of) C--
   4 --
   5 -- (c) The University of Glasgow 2004-2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 --
  10 -- This is where we walk over Cmm emitting an external representation,
  11 -- suitable for parsing, in a syntax strongly reminiscent of C--. This
  12 -- is the "External Core" for the Cmm layer.
  13 --
  14 -- As such, this should be a well-defined syntax: we want it to look nice.
  15 -- Thus, we try wherever possible to use syntax defined in [1],
  16 -- "The C-- Reference Manual", http://www.cminusminus.org/. We differ
  17 -- slightly, in some cases. For one, we use I8 .. I64 for types, rather
  18 -- than C--'s bits8 .. bits64.
  19 --
  20 -- We try to ensure that all information available in the abstract
  21 -- syntax is reproduced, or reproducible, in the concrete syntax.
  22 -- Data that is not in printed out can be reconstructed according to
  23 -- conventions used in the pretty printer. There are at least two such
  24 -- cases:
  25 --      1) if a value has wordRep type, the type is not appended in the
  26 --      output.
  27 --      2) MachOps that operate over wordRep type are printed in a
  28 --      C-style, rather than as their internal MachRep name.
  29 --
  30 -- These conventions produce much more readable Cmm output.
  31 --
  32 -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
  33 --
  34
  35 module PprCmm (
  36         writeCmms, pprCmms, pprCmm, pprStmt, pprExpr
  37   ) where
  38
  39 #include "HsVersions.h"
  40
  41 import Cmm
  42 import CmmUtils
  43 import MachOp
  44 import CLabel
  45
  46 import ForeignCall
  47 import Unique
  48 import Outputable
  49 import FastString
  50
  51 import Data.List
  52 import System.IO
  53 import Data.Maybe
  54
  55 pprCmms :: (Outputable info) => [GenCmm CmmStatic info CmmStmt] -> SDoc
  56 pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
  57         where
  58           separator = space $$ ptext SLIT("-------------------") $$ space
  59
  60 writeCmms :: Handle -> [Cmm] -> IO ()
  61 writeCmms handle cmms = printForC handle (pprCmms cmms)
  62
  63 -----------------------------------------------------------------------------
  64
  65 instance (Outputable info) => Outputable (GenCmm CmmStatic info CmmStmt) where
  66     ppr c = pprCmm c
  67
  68 instance (Outputable info) => Outputable (GenCmmTop CmmStatic info CmmStmt) where
  69     ppr t = pprTop t
  70
  71 instance Outputable CmmBasicBlock where
  72     ppr b = pprBBlock b
  73
  74 instance Outputable CmmStmt where
  75     ppr s = pprStmt s
  76
  77 instance Outputable CmmExpr where
  78     ppr e = pprExpr e
  79
  80 instance Outputable CmmReg where
  81     ppr e = pprReg e
  82
  83 instance Outputable LocalReg where
  84     ppr e = pprLocalReg e
  85
  86 instance Outputable GlobalReg where
  87     ppr e = pprGlobalReg e
  88
  89 instance Outputable CmmStatic where
  90     ppr e = pprStatic e
  91
  92 instance Outputable CmmInfo where
  93     ppr e = pprInfo e
  94
  95 -----------------------------------------------------------------------------
  96
  97 pprCmm :: (Outputable info) => GenCmm CmmStatic info CmmStmt -> SDoc
  98 pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
  99
 100 -- --------------------------------------------------------------------------
 101 -- Top level `procedure' blocks.
 102 --
 103 pprTop :: (Outputable info) => GenCmmTop CmmStatic info CmmStmt -> SDoc
 104 pprTop (CmmProc info lbl params blocks )
 105
 106   = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
 107          , nest 8 $ lbrace <+> ppr info $$ rbrace
 108          , nest 4 $ vcat (map ppr blocks)
 109          , rbrace ]
 110
 111 -- --------------------------------------------------------------------------
 112 -- We follow [1], 4.5
 113 --
 114 --      section "data" { ... }
 115 --
 116 pprTop (CmmData section ds) =
 117     (hang (pprSection section <+> lbrace) 4 (vcat (map pprStatic ds)))
 118     $$ rbrace
 119
 120 -- --------------------------------------------------------------------------
 121 instance Outputable CmmSafety where
 122   ppr CmmUnsafe = ptext SLIT("_unsafe_call_")
 123   ppr (CmmSafe srt) = ppr srt
 124
 125 -- --------------------------------------------------------------------------
 126 -- Info tables. The current pretty printer needs refinement
 127 -- but will work for now.
 128 --
 129 -- For ideas on how to refine it, they used to be printed in the
 130 -- style of C--'s 'stackdata' declaration, just inside the proc body,
 131 -- and were labelled with the procedure name ++ "_info".
 132 pprInfo (CmmNonInfo gc_target) =
 133     ptext SLIT("gc_target: ") <>
 134           ptext SLIT("TODO") --maybe (ptext SLIT("<none>")) pprBlockId gc_target
 135           -- ^ gc_target is currently unused and wired to a panic
 136 pprInfo (CmmInfo (ProfilingInfo closure_type closure_desc)
 137                  gc_target tag info) =
 138     vcat [ptext SLIT("type: ") <> pprLit closure_type,
 139           ptext SLIT("desc: ") <> pprLit closure_desc,
 140           ptext SLIT("gc_target: ") <>
 141                 ptext SLIT("TODO"), --maybe (ptext SLIT("<none>")) pprBlockId gc_target,
 142                 -- ^ gc_target is currently unused and wired to a panic
 143           ptext SLIT("tag: ") <> integer (toInteger tag),
 144           pprTypeInfo info]
 145
 146 pprTypeInfo (ConstrInfo layout constr descr) =
 147     vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
 148           ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
 149           ptext SLIT("constructor: ") <> integer (toInteger constr),
 150           pprLit descr]
 151 pprTypeInfo (FunInfo layout srt fun_type arity args slow_entry) =
 152     vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
 153           ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
 154           ptext SLIT("srt: ") <> ppr srt,
 155           ptext SLIT("fun_type: ") <> integer (toInteger fun_type),
 156           ptext SLIT("arity: ") <> integer (toInteger arity),
 157           --ppr args, -- TODO: needs to be printed
 158           ptext SLIT("slow: ") <> pprLit slow_entry
 159          ]
 160 pprTypeInfo (ThunkInfo layout srt) =
 161     vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
 162           ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
 163           ptext SLIT("srt: ") <> ppr srt]
 164 pprTypeInfo (ThunkSelectorInfo offset srt) =
 165     vcat [ptext SLIT("ptrs: ") <> integer (toInteger offset),
 166           ptext SLIT("srt: ") <> ppr srt]
 167 pprTypeInfo (ContInfo stack srt) =
 168     vcat [ptext SLIT("stack: ") <> ppr stack,
 169           ptext SLIT("srt: ") <> ppr srt]
 170
 171 -- --------------------------------------------------------------------------
 172 -- Basic blocks look like assembly blocks.
 173 --      lbl: stmt ; stmt ; ..
 174 pprBBlock :: CmmBasicBlock -> SDoc
 175 pprBBlock (BasicBlock ident stmts) =
 176     hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts))
 177
 178 -- --------------------------------------------------------------------------
 179 -- Statements. C-- usually, exceptions to this should be obvious.
 180 --
 181 pprStmt :: CmmStmt -> SDoc
 182 pprStmt stmt = case stmt of
 183
 184     -- ;
 185     CmmNop -> semi
 186
 187     --  // text
 188     CmmComment s -> text "//" <+> ftext s
 189
 190     -- reg = expr;
 191     CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
 192
 193     -- rep[lv] = expr;
 194     CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
 195         where
 196           rep = ppr ( cmmExprRep expr )
 197
 198     -- call "ccall" foo(x, y)[r1, r2];
 199     -- ToDo ppr volatile
 200     CmmCall (CmmForeignCall fn cconv) results args safety ->
 201         hcat [ if null results
 202                   then empty
 203                   else parens (commafy $ map ppr results) <>
 204                        ptext SLIT(" = "),
 205                ptext SLIT("call"), space,
 206                doubleQuotes(ppr cconv), space,
 207                target fn, parens  ( commafy $ map ppr args ),
 208                brackets (ppr safety), semi ]
 209         where
 210             target (CmmLit lit) = pprLit lit
 211             target fn'          = parens (ppr fn')
 212
 213     CmmCall (CmmPrim op) results args safety ->
 214         pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv)
 215                         results args safety)
 216         where
 217           lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
 218
 219     CmmBranch ident          -> genBranch ident
 220     CmmCondBranch expr ident -> genCondBranch expr ident
 221     CmmJump expr params      -> genJump expr params
 222     CmmReturn params         -> genReturn params
 223     CmmSwitch arg ids        -> genSwitch arg ids
 224
 225 -- --------------------------------------------------------------------------
 226 -- goto local label. [1], section 6.6
 227 --
 228 --     goto lbl;
 229 --
 230 genBranch :: BlockId -> SDoc
 231 genBranch ident =
 232     ptext SLIT("goto") <+> pprBlockId ident <> semi
 233
 234 -- --------------------------------------------------------------------------
 235 -- Conditional. [1], section 6.4
 236 --
 237 --     if (expr) { goto lbl; }
 238 --
 239 genCondBranch :: CmmExpr -> BlockId -> SDoc
 240 genCondBranch expr ident =
 241     hsep [ ptext SLIT("if")
 242          , parens(ppr expr)
 243          , ptext SLIT("goto")
 244          , pprBlockId ident <> semi ]
 245
 246 -- --------------------------------------------------------------------------
 247 -- A tail call. [1], Section 6.9
 248 --
 249 --     jump foo(a, b, c);
 250 --
 251 genJump :: CmmExpr -> [(CmmExpr, MachHint)] -> SDoc
 252 genJump expr args =
 253
 254     hcat [ ptext SLIT("jump")
 255          , space
 256          , if isTrivialCmmExpr expr
 257                 then pprExpr expr
 258                 else case expr of
 259                     CmmLoad (CmmReg _) _ -> pprExpr expr
 260                     _ -> parens (pprExpr expr)
 261          , space
 262          , parens  ( commafy $ map ppr args )
 263          , semi ]
 264
 265 -- --------------------------------------------------------------------------
 266 -- Return from a function. [1], Section 6.8.2 of version 1.128
 267 --
 268 --     return (a, b, c);
 269 --
 270 genReturn :: [(CmmExpr, MachHint)] -> SDoc
 271 genReturn args =
 272
 273     hcat [ ptext SLIT("return")
 274          , space
 275          , parens  ( commafy $ map ppr args )
 276          , semi ]
 277
 278 -- --------------------------------------------------------------------------
 279 -- Tabled jump to local label
 280 --
 281 -- The syntax is from [1], section 6.5
 282 --
 283 --      switch [0 .. n] (expr) { case ... ; }
 284 --
 285 genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
 286 genSwitch expr maybe_ids
 287
 288     = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
 289
 290       in hang (hcat [ ptext SLIT("switch [0 .. ")
 291                     , int (length maybe_ids - 1)
 292                     , ptext SLIT("] ")
 293                     , if isTrivialCmmExpr expr
 294                         then pprExpr expr
 295                         else parens (pprExpr expr)
 296                     , ptext SLIT(" {")
 297                     ])
 298             4 (vcat ( map caseify pairs )) $$ rbrace
 299
 300     where
 301       snds a b = (snd a) == (snd b)
 302
 303       caseify :: [(Int,Maybe BlockId)] -> SDoc
 304       caseify ixs@((i,Nothing):_)
 305         = ptext SLIT("/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
 306                 <> ptext SLIT(" */")
 307       caseify as
 308         = let (is,ids) = unzip as
 309           in hsep [ ptext SLIT("case")
 310                   , hcat (punctuate comma (map int is))
 311                   , ptext SLIT(": goto")
 312                   , pprBlockId (head [ id | Just id <- ids]) <> semi ]
 313
 314 -- --------------------------------------------------------------------------
 315 -- Expressions
 316 --
 317
 318 pprExpr :: CmmExpr -> SDoc
 319 pprExpr e
 320     = case e of
 321         CmmRegOff reg i ->
 322                 pprExpr (CmmMachOp (MO_Add rep)
 323                            [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
 324                 where rep = cmmRegRep reg
 325         CmmLit lit -> pprLit lit
 326         _other     -> pprExpr1 e
 327
 328 -- Here's the precedence table from CmmParse.y:
 329 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
 330 -- %left '|'
 331 -- %left '^'
 332 -- %left '&'
 333 -- %left '>>' '<<'
 334 -- %left '-' '+'
 335 -- %left '/' '*' '%'
 336 -- %right '~'
 337
 338 -- We just cope with the common operators for now, the rest will get
 339 -- a default conservative behaviour.
 340
 341 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
 342 pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
 343    = pprExpr7 x <+> doc <+> pprExpr7 y
 344 pprExpr1 e = pprExpr7 e
 345
 346 infixMachOp1 (MO_Eq     _) = Just (ptext SLIT("=="))
 347 infixMachOp1 (MO_Ne     _) = Just (ptext SLIT("!="))
 348 infixMachOp1 (MO_Shl    _) = Just (ptext SLIT("<<"))
 349 infixMachOp1 (MO_U_Shr  _) = Just (ptext SLIT(">>"))
 350 infixMachOp1 (MO_U_Ge   _) = Just (ptext SLIT(">="))
 351 infixMachOp1 (MO_U_Le   _) = Just (ptext SLIT("<="))
 352 infixMachOp1 (MO_U_Gt   _) = Just (char '>')
 353 infixMachOp1 (MO_U_Lt   _) = Just (char '<')
 354 infixMachOp1 _             = Nothing
 355
 356 -- %left '-' '+'
 357 pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
 358    = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
 359 pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
 360    = pprExpr7 x <+> doc <+> pprExpr8 y
 361 pprExpr7 e = pprExpr8 e
 362
 363 infixMachOp7 (MO_Add _)  = Just (char '+')
 364 infixMachOp7 (MO_Sub _)  = Just (char '-')
 365 infixMachOp7 _           = Nothing
 366
 367 -- %left '/' '*' '%'
 368 pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
 369    = pprExpr8 x <+> doc <+> pprExpr9 y
 370 pprExpr8 e = pprExpr9 e
 371
 372 infixMachOp8 (MO_U_Quot _) = Just (char '/')
 373 infixMachOp8 (MO_Mul _)    = Just (char '*')
 374 infixMachOp8 (MO_U_Rem _)  = Just (char '%')
 375 infixMachOp8 _             = Nothing
 376
 377 pprExpr9 :: CmmExpr -> SDoc
 378 pprExpr9 e =
 379    case e of
 380         CmmLit    lit       -> pprLit1 lit
 381         CmmLoad   expr rep  -> ppr rep <> brackets( ppr expr )
 382         CmmReg    reg       -> ppr reg
 383         CmmRegOff reg off   -> parens (ppr reg <+> char '+' <+> int off)
 384         CmmMachOp mop args  -> genMachOp mop args
 385
 386 genMachOp :: MachOp -> [CmmExpr] -> SDoc
 387 genMachOp mop args
 388    | Just doc <- infixMachOp mop = case args of
 389         -- dyadic
 390         [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
 391
 392         -- unary
 393         [x]   -> doc <> pprExpr9 x
 394
 395         _     -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
 396                           (pprMachOp mop <+>
 397                             parens (hcat $ punctuate comma (map pprExpr args)))
 398                           empty
 399
 400    | isJust (infixMachOp1 mop)
 401    || isJust (infixMachOp7 mop)
 402    || isJust (infixMachOp8 mop)  = parens (pprExpr (CmmMachOp mop args))
 403
 404    | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
 405         where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
 406                                  (show mop))
 407                 -- replace spaces in (show mop) with underscores,
 408
 409 --
 410 -- Unsigned ops on the word size of the machine get nice symbols.
 411 -- All else get dumped in their ugly format.
 412 --
 413 infixMachOp :: MachOp -> Maybe SDoc
 414 infixMachOp mop
 415         = case mop of
 416             MO_And    _ -> Just $ char '&'
 417             MO_Or     _ -> Just $ char '|'
 418             MO_Xor    _ -> Just $ char '^'
 419             MO_Not    _ -> Just $ char '~'
 420             MO_S_Neg  _ -> Just $ char '-' -- there is no unsigned neg :)
 421             _ -> Nothing
 422
 423 -- --------------------------------------------------------------------------
 424 -- Literals.
 425 --  To minimise line noise we adopt the convention that if the literal
 426 --  has the natural machine word size, we do not append the type
 427 --
 428 pprLit :: CmmLit -> SDoc
 429 pprLit lit = case lit of
 430     CmmInt i rep ->
 431         hcat [ (if i < 0 then parens else id)(integer i)
 432              , (if rep == wordRep
 433                     then empty
 434                     else space <> dcolon <+> ppr rep) ]
 435
 436     CmmFloat f rep     -> hsep [ rational f, dcolon, ppr rep ]
 437     CmmLabel clbl      -> pprCLabel clbl
 438     CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
 439     CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
 440                                   <> pprCLabel clbl2 <> ppr_offset i
 441
 442 pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit)
 443 pprLit1 lit                      = pprLit lit
 444
 445 ppr_offset :: Int -> SDoc
 446 ppr_offset i
 447     | i==0      = empty
 448     | i>=0      = char '+' <> int i
 449     | otherwise = char '-' <> int (-i)
 450
 451 -- --------------------------------------------------------------------------
 452 -- Static data.
 453 --      Strings are printed as C strings, and we print them as I8[],
 454 --      following C--
 455 --
 456 pprStatic :: CmmStatic -> SDoc
 457 pprStatic s = case s of
 458     CmmStaticLit lit   -> nest 4 $ ptext SLIT("const") <+> pprLit lit <> semi
 459     CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
 460     CmmAlign i         -> nest 4 $ text "align" <+> int i
 461     CmmDataLabel clbl  -> pprCLabel clbl <> colon
 462     CmmString s'       -> nest 4 $ text "I8[]" <+> text (show s')
 463
 464 -- --------------------------------------------------------------------------
 465 -- Registers, whether local (temps) or global
 466 --
 467 pprReg :: CmmReg -> SDoc
 468 pprReg r
 469     = case r of
 470         CmmLocal  local  -> pprLocalReg local
 471         CmmGlobal global -> pprGlobalReg global
 472
 473 --
 474 -- We only print the type of the local reg if it isn't wordRep
 475 --
 476 pprLocalReg :: LocalReg -> SDoc
 477 pprLocalReg (LocalReg uniq rep follow)
 478     = hcat [ char '_', ppr uniq, ty ] where
 479   ty = if rep == wordRep && follow == KindNonPtr
 480                 then empty
 481                 else dcolon <> ptr <> ppr rep
 482   ptr = if follow == KindNonPtr
 483                 then empty
 484                 else doubleQuotes (text "ptr")
 485
 486 -- needs to be kept in syn with Cmm.hs.GlobalReg
 487 --
 488 pprGlobalReg :: GlobalReg -> SDoc
 489 pprGlobalReg gr
 490     = case gr of
 491         VanillaReg n   -> char 'R' <> int n
 492         FloatReg   n   -> char 'F' <> int n
 493         DoubleReg  n   -> char 'D' <> int n
 494         LongReg    n   -> char 'L' <> int n
 495         Sp             -> ptext SLIT("Sp")
 496         SpLim          -> ptext SLIT("SpLim")
 497         Hp             -> ptext SLIT("Hp")
 498         HpLim          -> ptext SLIT("HpLim")
 499         CurrentTSO     -> ptext SLIT("CurrentTSO")
 500         CurrentNursery -> ptext SLIT("CurrentNursery")
 501         HpAlloc        -> ptext SLIT("HpAlloc")
 502         GCEnter1       -> ptext SLIT("stg_gc_enter_1")
 503         GCFun          -> ptext SLIT("stg_gc_fun")
 504         BaseReg        -> ptext SLIT("BaseReg")
 505         PicBaseReg     -> ptext SLIT("PicBaseReg")
 506
 507 -- --------------------------------------------------------------------------
 508 -- data sections
 509 --
 510 pprSection :: Section -> SDoc
 511 pprSection s = case s of
 512     Text              -> section <+> doubleQuotes (ptext SLIT("text"))
 513     Data              -> section <+> doubleQuotes (ptext SLIT("data"))
 514     ReadOnlyData      -> section <+> doubleQuotes (ptext SLIT("readonly"))
 515     RelocatableReadOnlyData
 516                       -> section <+> doubleQuotes (ptext SLIT("relreadonly"))
 517     UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised"))
 518     OtherSection s'   -> section <+> doubleQuotes (text s')
 519  where
 520     section = ptext SLIT("section")
 521
 522 -- --------------------------------------------------------------------------
 523 -- Basic block ids
 524 --
 525 pprBlockId :: BlockId -> SDoc
 526 pprBlockId b = ppr $ getUnique b
 527
 528 -----------------------------------------------------------------------------
 529
 530 commafy :: [SDoc] -> SDoc
 531 commafy xs = hsep $ punctuate comma xs
 532