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 Outputable
  49 import FastString
  50
  51 import Data.List
  52 import System.IO
  53 import Data.Maybe
  54
  55 -- Temp Jan08
  56 import SMRep
  57 import ClosureInfo
  58 #include "../includes/StgFun.h"
  59
  60
  61 pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatic info g] -> SDoc
  62 pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
  63         where
  64           separator = space $$ ptext (sLit "-------------------") $$ space
  65
  66 writeCmms :: Handle -> [Cmm] -> IO ()
  67 writeCmms handle cmms = printForC handle (pprCmms cmms)
  68
  69 -----------------------------------------------------------------------------
  70
  71 instance (Outputable d, Outputable info, Outputable g)
  72     => Outputable (GenCmm d info g) where
  73     ppr c = pprCmm c
  74
  75 instance (Outputable d, Outputable info, Outputable i)
  76         => Outputable (GenCmmTop d info i) where
  77     ppr t = pprTop t
  78
  79 instance (Outputable instr) => Outputable (ListGraph instr) where
  80     ppr (ListGraph blocks) = vcat (map ppr blocks)
  81
  82 instance (Outputable instr) => Outputable (GenBasicBlock instr) where
  83     ppr b = pprBBlock b
  84
  85 instance Outputable CmmStmt where
  86     ppr s = pprStmt s
  87
  88 instance Outputable CmmExpr where
  89     ppr e = pprExpr e
  90
  91 instance Outputable CmmReg where
  92     ppr e = pprReg e
  93
  94 instance Outputable CmmLit where
  95     ppr l = pprLit l
  96
  97 instance Outputable LocalReg where
  98     ppr e = pprLocalReg e
  99
 100 instance Outputable Area where
 101     ppr e = pprArea e
 102
 103 instance Outputable GlobalReg where
 104     ppr e = pprGlobalReg e
 105
 106 instance Outputable CmmStatic where
 107     ppr e = pprStatic e
 108
 109 instance Outputable CmmInfo where
 110     ppr e = pprInfo e
 111
 112
 113
 114 -----------------------------------------------------------------------------
 115
 116 pprCmm :: (Outputable d, Outputable info, Outputable g) => GenCmm d info g -> SDoc
 117 pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
 118
 119 -- --------------------------------------------------------------------------
 120 -- Top level `procedure' blocks.
 121 --
 122 pprTop  :: (Outputable d, Outputable info, Outputable i)
 123         => GenCmmTop d info i -> SDoc
 124
 125 pprTop (CmmProc info lbl params graph )
 126
 127   = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params)
 128          , nest 8 $ lbrace <+> ppr info $$ rbrace
 129          , nest 4 $ ppr graph
 130          , rbrace ]
 131
 132 -- --------------------------------------------------------------------------
 133 -- We follow [1], 4.5
 134 --
 135 --      section "data" { ... }
 136 --
 137 pprTop (CmmData section ds) =
 138     (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds)))
 139     $$ rbrace
 140
 141 -- --------------------------------------------------------------------------
 142 instance Outputable CmmSafety where
 143   ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
 144   ppr (CmmSafe srt) = ppr srt
 145
 146 -- --------------------------------------------------------------------------
 147 -- Info tables. The current pretty printer needs refinement
 148 -- but will work for now.
 149 --
 150 -- For ideas on how to refine it, they used to be printed in the
 151 -- style of C--'s 'stackdata' declaration, just inside the proc body,
 152 -- and were labelled with the procedure name ++ "_info".
 153 pprInfo :: CmmInfo -> SDoc
 154 pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) =
 155     vcat [{-ptext (sLit "gc_target: ") <>
 156                 maybe (ptext (sLit "<none>")) ppr gc_target,-}
 157           ptext (sLit "update_frame: ") <>
 158                 maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame]
 159 pprInfo (CmmInfo _gc_target update_frame
 160          (CmmInfoTable stat_clos (ProfilingInfo closure_type closure_desc) tag info)) =
 161     vcat [{-ptext (sLit "gc_target: ") <>
 162                 maybe (ptext (sLit "<none>")) ppr gc_target,-}
 163           ptext (sLit "has static closure: ") <> ppr stat_clos <+>
 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 (ppr 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") <+> ppr 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          , ppr 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                   , ppr (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     CmmBlock id        -> ppr id
 518     CmmHighStackMark -> text "<highSp>"
 519
 520 pprLit1 :: CmmLit -> SDoc
 521 pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
 522 pprLit1 lit                  = pprLit lit
 523
 524 ppr_offset :: Int -> SDoc
 525 ppr_offset i
 526     | i==0      = empty
 527     | i>=0      = char '+' <> int i
 528     | otherwise = char '-' <> int (-i)
 529
 530 -- --------------------------------------------------------------------------
 531 -- Static data.
 532 --      Strings are printed as C strings, and we print them as I8[],
 533 --      following C--
 534 --
 535 pprStatic :: CmmStatic -> SDoc
 536 pprStatic s = case s of
 537     CmmStaticLit lit   -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi
 538     CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
 539     CmmAlign i         -> nest 4 $ text "align" <+> int i
 540     CmmDataLabel clbl  -> pprCLabel clbl <> colon
 541     CmmString s'       -> nest 4 $ text "I8[]" <+> text (show s')
 542
 543 -- --------------------------------------------------------------------------
 544 -- Registers, whether local (temps) or global
 545 --
 546 pprReg :: CmmReg -> SDoc
 547 pprReg r
 548     = case r of
 549         CmmLocal  local  -> pprLocalReg  local
 550         CmmGlobal global -> pprGlobalReg global
 551
 552 --
 553 -- We only print the type of the local reg if it isn't wordRep
 554 --
 555 pprLocalReg :: LocalReg -> SDoc
 556 pprLocalReg (LocalReg uniq rep)
 557 --   = ppr rep <> char '_' <> ppr uniq
 558 -- Temp Jan08
 559    = char '_' <> ppr uniq <>
 560        (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08               -- sigh
 561                     then dcolon <> ptr <> ppr rep
 562                     else dcolon <> ptr <> ppr rep)
 563    where
 564      ptr = empty
 565          --if isGcPtrType rep
 566          --      then doubleQuotes (text "ptr")
 567          --      else empty
 568
 569 -- Stack areas
 570 pprArea :: Area -> SDoc
 571 pprArea (RegSlot r)   = hcat [ text "slot<", ppr r, text ">" ]
 572 pprArea (CallArea id) = pprAreaId id
 573
 574 pprAreaId :: AreaId -> SDoc
 575 pprAreaId Old        = text "old"
 576 pprAreaId (Young id) = hcat [ text "young<", ppr id, text ">" ]
 577
 578 -- needs to be kept in syn with Cmm.hs.GlobalReg
 579 --
 580 pprGlobalReg :: GlobalReg -> SDoc
 581 pprGlobalReg gr
 582     = case gr of
 583         VanillaReg n _ -> char 'R' <> int n
 584 -- Temp Jan08
 585 --        VanillaReg n VNonGcPtr -> char 'R' <> int n
 586 --        VanillaReg n VGcPtr    -> char 'P' <> int n
 587         FloatReg   n   -> char 'F' <> int n
 588         DoubleReg  n   -> char 'D' <> int n
 589         LongReg    n   -> char 'L' <> int n
 590         Sp             -> ptext (sLit "Sp")
 591         SpLim          -> ptext (sLit "SpLim")
 592         Hp             -> ptext (sLit "Hp")
 593         HpLim          -> ptext (sLit "HpLim")
 594         CurrentTSO     -> ptext (sLit "CurrentTSO")
 595         CurrentNursery -> ptext (sLit "CurrentNursery")
 596         HpAlloc        -> ptext (sLit "HpAlloc")
 597         EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info")
 598         GCEnter1       -> ptext (sLit "stg_gc_enter_1")
 599         GCFun          -> ptext (sLit "stg_gc_fun")
 600         BaseReg        -> ptext (sLit "BaseReg")
 601         PicBaseReg     -> ptext (sLit "PicBaseReg")
 602
 603 -- --------------------------------------------------------------------------
 604 -- data sections
 605 --
 606 pprSection :: Section -> SDoc
 607 pprSection s = case s of
 608     Text              -> section <+> doubleQuotes (ptext (sLit "text"))
 609     Data              -> section <+> doubleQuotes (ptext (sLit "data"))
 610     ReadOnlyData      -> section <+> doubleQuotes (ptext (sLit "readonly"))
 611     ReadOnlyData16    -> section <+> doubleQuotes (ptext (sLit "readonly16"))
 612     RelocatableReadOnlyData
 613                       -> section <+> doubleQuotes (ptext (sLit "relreadonly"))
 614     UninitialisedData -> section <+> doubleQuotes (ptext (sLit "uninitialised"))
 615     OtherSection s'   -> section <+> doubleQuotes (text s')
 616  where
 617     section = ptext (sLit "section")
 618
 619 -----------------------------------------------------------------------------
 620
 621 commafy :: [SDoc] -> SDoc
 622 commafy xs = fsep $ punctuate comma xs