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