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       pprSection, pprStatic, pprLit
  38     )
  39 where
  40
  41 import BlockId
  42 import Cmm
  43 import CmmUtils
  44 import CLabel
  45
  46
  47 import ForeignCall
  48 import Unique
  49 import Outputable
  50 import FastString
  51
  52 import Data.List
  53 import System.IO
  54 import Data.Maybe
  55
  56 -- Temp Jan08
  57 import SMRep
  58 import ClosureInfo
  59 #include "../includes/StgFun.h"
  60
  61
  62 pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatic info g] -> SDoc
  63 pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
  64         where
  65           separator = space $$ ptext (sLit "-------------------") $$ space
  66
  67 writeCmms :: Handle -> [Cmm] -> IO ()
  68 writeCmms handle cmms = printForC handle (pprCmms cmms)
  69
  70 -----------------------------------------------------------------------------
  71
  72 instance (Outputable d, Outputable info, Outputable g)
  73     => Outputable (GenCmm d info g) where
  74     ppr c = pprCmm c
  75
  76 instance (Outputable d, Outputable info, Outputable i)
  77         => Outputable (GenCmmTop d info i) where
  78     ppr t = pprTop t
  79
  80 instance (Outputable instr) => Outputable (ListGraph instr) where
  81     ppr (ListGraph blocks) = vcat (map ppr blocks)
  82
  83 instance (Outputable instr) => Outputable (GenBasicBlock instr) where
  84     ppr b = pprBBlock b
  85
  86 instance Outputable CmmStmt where
  87     ppr s = pprStmt s
  88
  89 instance Outputable CmmExpr where
  90     ppr e = pprExpr e
  91
  92 instance Outputable CmmReg where
  93     ppr e = pprReg e
  94
  95 instance Outputable CmmLit where
  96     ppr l = pprLit l
  97
  98 instance Outputable LocalReg where
  99     ppr e = pprLocalReg e
 100
 101 instance Outputable Area where
 102     ppr e = pprArea e
 103
 104 instance Outputable GlobalReg where
 105     ppr e = pprGlobalReg e
 106
 107 instance Outputable CmmStatic where
 108     ppr e = pprStatic e
 109
 110 instance Outputable CmmInfo where
 111     ppr e = pprInfo e
 112
 113
 114
 115 -----------------------------------------------------------------------------
 116
 117 pprCmm :: (Outputable d, Outputable info, Outputable g) => GenCmm d info g -> SDoc
 118 pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
 119
 120 -- --------------------------------------------------------------------------
 121 -- Top level `procedure' blocks.
 122 --
 123 pprTop  :: (Outputable d, Outputable info, Outputable i)
 124         => GenCmmTop d info i -> SDoc
 125
 126 pprTop (CmmProc info lbl params graph )
 127
 128   = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
 129          , nest 8 $ lbrace <+> ppr info $$ rbrace
 130          , nest 4 $ ppr graph
 131          , rbrace ]
 132
 133 -- --------------------------------------------------------------------------
 134 -- We follow [1], 4.5
 135 --
 136 --      section "data" { ... }
 137 --
 138 pprTop (CmmData section ds) =
 139     (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds)))
 140     $$ rbrace
 141
 142 -- --------------------------------------------------------------------------
 143 instance Outputable CmmSafety where
 144   ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
 145   ppr (CmmSafe srt) = ppr srt
 146
 147 -- --------------------------------------------------------------------------
 148 -- Info tables. The current pretty printer needs refinement
 149 -- but will work for now.
 150 --
 151 -- For ideas on how to refine it, they used to be printed in the
 152 -- style of C--'s 'stackdata' declaration, just inside the proc body,
 153 -- and were labelled with the procedure name ++ "_info".
 154 pprInfo :: CmmInfo -> SDoc
 155 pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) =
 156     vcat [{-ptext (sLit "gc_target: ") <>
 157                 maybe (ptext (sLit "<none>")) pprBlockId gc_target,-}
 158           ptext (sLit "update_frame: ") <>
 159                 maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame]
 160 pprInfo (CmmInfo _gc_target update_frame
 161          (CmmInfoTable (ProfilingInfo closure_type closure_desc) tag info)) =
 162     vcat [{-ptext (sLit "gc_target: ") <>
 163                 maybe (ptext (sLit "<none>")) pprBlockId gc_target,-}
 164           ptext (sLit "update_frame: ") <>
 165                 maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame,
 166           ptext (sLit "type: ") <> pprLit closure_type,
 167           ptext (sLit "desc: ") <> pprLit closure_desc,
 168           ptext (sLit "tag: ") <> integer (toInteger tag),
 169           pprTypeInfo info]
 170
 171 pprTypeInfo :: ClosureTypeInfo -> SDoc
 172 pprTypeInfo (ConstrInfo layout constr descr) =
 173     vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
 174           ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
 175           ptext (sLit "constructor: ") <> integer (toInteger constr),
 176           pprLit descr]
 177 pprTypeInfo (FunInfo layout srt arity _args slow_entry) =
 178     vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
 179           ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
 180           ptext (sLit "srt: ") <> ppr srt,
 181 -- Temp Jan08
 182           ptext (sLit ("fun_type: ")) <> integer (toInteger (argDescrType _args)),
 183
 184           ptext (sLit "arity: ") <> integer (toInteger arity),
 185           --ptext (sLit "args: ") <> ppr args, -- TODO: needs to be printed
 186           ptext (sLit "slow: ") <> pprLit slow_entry
 187          ]
 188 pprTypeInfo (ThunkInfo layout srt) =
 189     vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
 190           ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
 191           ptext (sLit "srt: ") <> ppr srt]
 192 pprTypeInfo (ThunkSelectorInfo offset srt) =
 193     vcat [ptext (sLit "ptrs: ") <> integer (toInteger offset),
 194           ptext (sLit "srt: ") <> ppr srt]
 195 pprTypeInfo (ContInfo stack srt) =
 196     vcat [ptext (sLit "stack: ") <> ppr stack,
 197           ptext (sLit "srt: ") <> ppr srt]
 198
 199 -- Temp Jan08
 200 argDescrType :: ArgDescr -> StgHalfWord
 201 -- The "argument type" RTS field type
 202 argDescrType (ArgSpec n) = n
 203 argDescrType (ArgGen liveness)
 204   | isBigLiveness liveness = ARG_GEN_BIG
 205   | otherwise              = ARG_GEN
 206
 207 -- Temp Jan08
 208 isBigLiveness :: Liveness -> Bool
 209 isBigLiveness (BigLiveness _)   = True
 210 isBigLiveness (SmallLiveness _) = False
 211
 212
 213 pprUpdateFrame :: UpdateFrame -> SDoc
 214 pprUpdateFrame (UpdateFrame expr args) =
 215     hcat [ ptext (sLit "jump")
 216          , space
 217          , if isTrivialCmmExpr expr
 218                 then pprExpr expr
 219                 else case expr of
 220                     CmmLoad (CmmReg _) _ -> pprExpr expr
 221                     _ -> parens (pprExpr expr)
 222          , space
 223          , parens  ( commafy $ map ppr args ) ]
 224
 225
 226 -- --------------------------------------------------------------------------
 227 -- Basic blocks look like assembly blocks.
 228 --      lbl: stmt ; stmt ; ..
 229 pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
 230 pprBBlock (BasicBlock ident stmts) =
 231     hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts))
 232
 233 -- --------------------------------------------------------------------------
 234 -- Statements. C-- usually, exceptions to this should be obvious.
 235 --
 236 pprStmt :: CmmStmt -> SDoc
 237 pprStmt stmt = case stmt of
 238
 239     -- ;
 240     CmmNop -> semi
 241
 242     --  // text
 243     CmmComment s -> text "//" <+> ftext s
 244
 245     -- reg = expr;
 246     CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
 247
 248     -- rep[lv] = expr;
 249     CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
 250         where
 251           rep = ppr ( cmmExprType expr )
 252
 253     -- call "ccall" foo(x, y)[r1, r2];
 254     -- ToDo ppr volatile
 255     CmmCall (CmmCallee fn cconv) results args safety ret ->
 256         sep  [ pp_lhs <+> pp_conv
 257              , nest 2 (pprExpr9 fn <>
 258                        parens (commafy (map ppr_ar args)))
 259                <> brackets (ppr safety)
 260              , case ret of CmmMayReturn -> empty
 261                            CmmNeverReturns -> ptext $ sLit (" never returns")
 262              ] <> semi
 263         where
 264           pp_lhs | null results = empty
 265                  | otherwise    = commafy (map ppr_ar results) <+> equals
 266                 -- Don't print the hints on a native C-- call
 267           ppr_ar (CmmHinted ar k) = case cconv of
 268                             CmmCallConv -> ppr ar
 269                             _           -> ppr (ar,k)
 270           pp_conv = case cconv of
 271                       CmmCallConv -> empty
 272                       _           -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv)
 273
 274     CmmCall (CmmPrim op) results args safety ret ->
 275         pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
 276                         results args safety ret)
 277         where
 278           lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
 279
 280     CmmBranch ident          -> genBranch ident
 281     CmmCondBranch expr ident -> genCondBranch expr ident
 282     CmmJump expr params      -> genJump expr params
 283     CmmReturn params         -> genReturn params
 284     CmmSwitch arg ids        -> genSwitch arg ids
 285
 286 instance Outputable ForeignHint where
 287   ppr NoHint     = empty
 288   ppr SignedHint = quotes(text "signed")
 289 --  ppr AddrHint   = quotes(text "address")
 290 -- Temp Jan08
 291   ppr AddrHint   = (text "PtrHint")
 292
 293 -- Just look like a tuple, since it was a tuple before
 294 -- ... is that a good idea? --Isaac Dupree
 295 instance (Outputable a) => Outputable (CmmHinted a) where
 296   ppr (CmmHinted a k) = ppr (a, k)
 297
 298 -- --------------------------------------------------------------------------
 299 -- goto local label. [1], section 6.6
 300 --
 301 --     goto lbl;
 302 --
 303 genBranch :: BlockId -> SDoc
 304 genBranch ident =
 305     ptext (sLit "goto") <+> pprBlockId ident <> semi
 306
 307 -- --------------------------------------------------------------------------
 308 -- Conditional. [1], section 6.4
 309 --
 310 --     if (expr) { goto lbl; }
 311 --
 312 genCondBranch :: CmmExpr -> BlockId -> SDoc
 313 genCondBranch expr ident =
 314     hsep [ ptext (sLit "if")
 315          , parens(ppr expr)
 316          , ptext (sLit "goto")
 317          , pprBlockId ident <> semi ]
 318
 319 -- --------------------------------------------------------------------------
 320 -- A tail call. [1], Section 6.9
 321 --
 322 --     jump foo(a, b, c);
 323 --
 324 genJump :: CmmExpr -> [CmmHinted CmmExpr] -> SDoc
 325 genJump expr args =
 326     hcat [ ptext (sLit "jump")
 327          , space
 328          , if isTrivialCmmExpr expr
 329                 then pprExpr expr
 330                 else case expr of
 331                     CmmLoad (CmmReg _) _ -> pprExpr expr
 332                     _ -> parens (pprExpr expr)
 333          , space
 334          , parens  ( commafy $ map ppr args )
 335          , semi ]
 336
 337
 338 -- --------------------------------------------------------------------------
 339 -- Return from a function. [1], Section 6.8.2 of version 1.128
 340 --
 341 --     return (a, b, c);
 342 --
 343 genReturn :: [CmmHinted CmmExpr] -> SDoc
 344 genReturn args =
 345     hcat [ ptext (sLit "return")
 346          , space
 347          , parens  ( commafy $ map ppr args )
 348          , semi ]
 349
 350 -- --------------------------------------------------------------------------
 351 -- Tabled jump to local label
 352 --
 353 -- The syntax is from [1], section 6.5
 354 --
 355 --      switch [0 .. n] (expr) { case ... ; }
 356 --
 357 genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
 358 genSwitch expr maybe_ids
 359
 360     = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
 361
 362       in hang (hcat [ ptext (sLit "switch [0 .. ")
 363                     , int (length maybe_ids - 1)
 364                     , ptext (sLit "] ")
 365                     , if isTrivialCmmExpr expr
 366                         then pprExpr expr
 367                         else parens (pprExpr expr)
 368                     , ptext (sLit " {")
 369                     ])
 370             4 (vcat ( map caseify pairs )) $$ rbrace
 371
 372     where
 373       snds a b = (snd a) == (snd b)
 374
 375       caseify :: [(Int,Maybe BlockId)] -> SDoc
 376       caseify ixs@((_,Nothing):_)
 377         = ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
 378                 <> ptext (sLit " */")
 379       caseify as
 380         = let (is,ids) = unzip as
 381           in hsep [ ptext (sLit "case")
 382                   , hcat (punctuate comma (map int is))
 383                   , ptext (sLit ": goto")
 384                   , pprBlockId (head [ id | Just id <- ids]) <> semi ]
 385
 386 -- --------------------------------------------------------------------------
 387 -- Expressions
 388 --
 389
 390 pprExpr :: CmmExpr -> SDoc
 391 pprExpr e
 392     = case e of
 393         CmmRegOff reg i ->
 394                 pprExpr (CmmMachOp (MO_Add rep)
 395                            [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
 396                 where rep = typeWidth (cmmRegType reg)
 397         CmmLit lit -> pprLit lit
 398         _other     -> pprExpr1 e
 399
 400 -- Here's the precedence table from CmmParse.y:
 401 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
 402 -- %left '|'
 403 -- %left '^'
 404 -- %left '&'
 405 -- %left '>>' '<<'
 406 -- %left '-' '+'
 407 -- %left '/' '*' '%'
 408 -- %right '~'
 409
 410 -- We just cope with the common operators for now, the rest will get
 411 -- a default conservative behaviour.
 412
 413 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
 414 pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc
 415 pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
 416    = pprExpr7 x <+> doc <+> pprExpr7 y
 417 pprExpr1 e = pprExpr7 e
 418
 419 infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
 420
 421 infixMachOp1 (MO_Eq     _) = Just (ptext (sLit "=="))
 422 infixMachOp1 (MO_Ne     _) = Just (ptext (sLit "!="))
 423 infixMachOp1 (MO_Shl    _) = Just (ptext (sLit "<<"))
 424 infixMachOp1 (MO_U_Shr  _) = Just (ptext (sLit ">>"))
 425 infixMachOp1 (MO_U_Ge   _) = Just (ptext (sLit ">="))
 426 infixMachOp1 (MO_U_Le   _) = Just (ptext (sLit "<="))
 427 infixMachOp1 (MO_U_Gt   _) = Just (char '>')
 428 infixMachOp1 (MO_U_Lt   _) = Just (char '<')
 429 infixMachOp1 _             = Nothing
 430
 431 -- %left '-' '+'
 432 pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
 433    = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
 434 pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
 435    = pprExpr7 x <+> doc <+> pprExpr8 y
 436 pprExpr7 e = pprExpr8 e
 437
 438 infixMachOp7 (MO_Add _)  = Just (char '+')
 439 infixMachOp7 (MO_Sub _)  = Just (char '-')
 440 infixMachOp7 _           = Nothing
 441
 442 -- %left '/' '*' '%'
 443 pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
 444    = pprExpr8 x <+> doc <+> pprExpr9 y
 445 pprExpr8 e = pprExpr9 e
 446
 447 infixMachOp8 (MO_U_Quot _) = Just (char '/')
 448 infixMachOp8 (MO_Mul _)    = Just (char '*')
 449 infixMachOp8 (MO_U_Rem _)  = Just (char '%')
 450 infixMachOp8 _             = Nothing
 451
 452 pprExpr9 :: CmmExpr -> SDoc
 453 pprExpr9 e =
 454    case e of
 455         CmmLit    lit       -> pprLit1 lit
 456         CmmLoad   expr rep  -> ppr rep <> brackets( ppr expr )
 457         CmmReg    reg       -> ppr reg
 458         CmmRegOff  reg off  -> parens (ppr reg <+> char '+' <+> int off)
 459         CmmStackSlot a off  -> parens (ppr a   <+> char '+' <+> int off)
 460         CmmMachOp mop args  -> genMachOp mop args
 461
 462 genMachOp :: MachOp -> [CmmExpr] -> SDoc
 463 genMachOp mop args
 464    | Just doc <- infixMachOp mop = case args of
 465         -- dyadic
 466         [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
 467
 468         -- unary
 469         [x]   -> doc <> pprExpr9 x
 470
 471         _     -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
 472                           (pprMachOp mop <+>
 473                             parens (hcat $ punctuate comma (map pprExpr args)))
 474                           empty
 475
 476    | isJust (infixMachOp1 mop)
 477    || isJust (infixMachOp7 mop)
 478    || isJust (infixMachOp8 mop)  = parens (pprExpr (CmmMachOp mop args))
 479
 480    | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
 481         where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
 482                                  (show mop))
 483                 -- replace spaces in (show mop) with underscores,
 484
 485 --
 486 -- Unsigned ops on the word size of the machine get nice symbols.
 487 -- All else get dumped in their ugly format.
 488 --
 489 infixMachOp :: MachOp -> Maybe SDoc
 490 infixMachOp mop
 491         = case mop of
 492             MO_And    _ -> Just $ char '&'
 493             MO_Or     _ -> Just $ char '|'
 494             MO_Xor    _ -> Just $ char '^'
 495             MO_Not    _ -> Just $ char '~'
 496             MO_S_Neg  _ -> Just $ char '-' -- there is no unsigned neg :)
 497             _ -> Nothing
 498
 499 -- --------------------------------------------------------------------------
 500 -- Literals.
 501 --  To minimise line noise we adopt the convention that if the literal
 502 --  has the natural machine word size, we do not append the type
 503 --
 504 pprLit :: CmmLit -> SDoc
 505 pprLit lit = case lit of
 506     CmmInt i rep ->
 507         hcat [ (if i < 0 then parens else id)(integer i)
 508              , (if rep == wordWidth
 509                     then empty
 510                     else space <> dcolon <+> ppr rep) ]
 511
 512     CmmFloat f rep     -> hsep [ rational f, dcolon, ppr rep ]
 513     CmmLabel clbl      -> pprCLabel clbl
 514     CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
 515     CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
 516                                   <> pprCLabel clbl2 <> ppr_offset i
 517
 518 pprLit1 :: CmmLit -> SDoc
 519 pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
 520 pprLit1 lit                  = pprLit lit
 521
 522 ppr_offset :: Int -> SDoc
 523 ppr_offset i
 524     | i==0      = empty
 525     | i>=0      = char '+' <> int i
 526     | otherwise = char '-' <> int (-i)
 527
 528 -- --------------------------------------------------------------------------
 529 -- Static data.
 530 --      Strings are printed as C strings, and we print them as I8[],
 531 --      following C--
 532 --
 533 pprStatic :: CmmStatic -> SDoc
 534 pprStatic s = case s of
 535     CmmStaticLit lit   -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi
 536     CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
 537     CmmAlign i         -> nest 4 $ text "align" <+> int i
 538     CmmDataLabel clbl  -> pprCLabel clbl <> colon
 539     CmmString s'       -> nest 4 $ text "I8[]" <+> text (show s')
 540
 541 -- --------------------------------------------------------------------------
 542 -- Registers, whether local (temps) or global
 543 --
 544 pprReg :: CmmReg -> SDoc
 545 pprReg r
 546     = case r of
 547         CmmLocal  local  -> pprLocalReg  local
 548         CmmGlobal global -> pprGlobalReg global
 549
 550 --
 551 -- We only print the type of the local reg if it isn't wordRep
 552 --
 553 pprLocalReg :: LocalReg -> SDoc
 554 pprLocalReg (LocalReg uniq rep)
 555 --   = ppr rep <> char '_' <> ppr uniq
 556 -- Temp Jan08
 557    = char '_' <> ppr uniq <>
 558        (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08               -- sigh
 559                     then dcolon <> ptr <> ppr rep
 560                     else dcolon <> ptr <> ppr rep)
 561    where
 562      ptr = empty
 563          --if isGcPtrType rep
 564          --      then doubleQuotes (text "ptr")
 565          --      else empty
 566
 567 -- Stack areas
 568 pprArea :: Area -> SDoc
 569 pprArea (RegSlot r)   = hcat [ text "slot<", ppr r, text ">" ]
 570 pprArea (CallArea id) = pprAreaId id
 571
 572 pprAreaId :: AreaId -> SDoc
 573 pprAreaId Old        = text "old"
 574 pprAreaId (Young id) = hcat [ text "young<", ppr id, text ">" ]
 575
 576 -- needs to be kept in syn with Cmm.hs.GlobalReg
 577 --
 578 pprGlobalReg :: GlobalReg -> SDoc
 579 pprGlobalReg gr
 580     = case gr of
 581         VanillaReg n _ -> char 'R' <> int n
 582 -- Temp Jan08
 583 --        VanillaReg n VNonGcPtr -> char 'R' <> int n
 584 --        VanillaReg n VGcPtr    -> char 'P' <> int n
 585         FloatReg   n   -> char 'F' <> int n
 586         DoubleReg  n   -> char 'D' <> int n
 587         LongReg    n   -> char 'L' <> int n
 588         Sp             -> ptext (sLit "Sp")
 589         SpLim          -> ptext (sLit "SpLim")
 590         Hp             -> ptext (sLit "Hp")
 591         HpLim          -> ptext (sLit "HpLim")
 592         CurrentTSO     -> ptext (sLit "CurrentTSO")
 593         CurrentNursery -> ptext (sLit "CurrentNursery")
 594         HpAlloc        -> ptext (sLit "HpAlloc")
 595         EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info")
 596         GCEnter1       -> ptext (sLit "stg_gc_enter_1")
 597         GCFun          -> ptext (sLit "stg_gc_fun")
 598         BaseReg        -> ptext (sLit "BaseReg")
 599         PicBaseReg     -> ptext (sLit "PicBaseReg")
 600
 601 -- --------------------------------------------------------------------------
 602 -- data sections
 603 --
 604 pprSection :: Section -> SDoc
 605 pprSection s = case s of
 606     Text              -> section <+> doubleQuotes (ptext (sLit "text"))
 607     Data              -> section <+> doubleQuotes (ptext (sLit "data"))
 608     ReadOnlyData      -> section <+> doubleQuotes (ptext (sLit "readonly"))
 609     ReadOnlyData16    -> section <+> doubleQuotes (ptext (sLit "readonly16"))
 610     RelocatableReadOnlyData
 611                       -> section <+> doubleQuotes (ptext (sLit "relreadonly"))
 612     UninitialisedData -> section <+> doubleQuotes (ptext (sLit "uninitialised"))
 613     OtherSection s'   -> section <+> doubleQuotes (text s')
 614  where
 615     section = ptext (sLit "section")
 616
 617 -- --------------------------------------------------------------------------
 618 -- Basic block ids
 619 --
 620 pprBlockId :: BlockId -> SDoc
 621 pprBlockId b = ppr $ getUnique b
 622
 623 -----------------------------------------------------------------------------
 624
 625 commafy :: [SDoc] -> SDoc
 626 commafy xs = fsep $ punctuate comma xs