ghc/compiler/stgSyn/StgSyn.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation}
   5
   6 This data type represents programs just before code generation
   7 (conversion to @AbstractC@): basically, what we have is a stylised
   8 form of @CoreSyntax@, the style being one that happens to be ideally
   9 suited to spineless tagless code generation.
  10
  11 \begin{code}
  12 #include "HsVersions.h"
  13
  14 module StgSyn (
  15         GenStgArg(..),
  16         GenStgLiveVars(..),
  17
  18         GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
  19         GenStgCaseAlts(..), GenStgCaseDefault(..),
  20
  21         UpdateFlag(..),
  22
  23         StgBinderInfo(..),
  24         stgArgOcc, stgUnsatOcc, stgStdHeapOcc, stgNoUpdHeapOcc,
  25         stgNormalOcc, stgFakeFunAppOcc,
  26         combineStgBinderInfo,
  27
  28         -- a set of synonyms for the most common (only :-) parameterisation
  29         StgArg(..), StgLiveVars(..),
  30         StgBinding(..), StgExpr(..), StgRhs(..),
  31         StgCaseAlts(..), StgCaseDefault(..),
  32
  33         pprPlainStgBinding,
  34         getArgPrimRep,
  35         isLitLitArg,
  36         stgArity,
  37         collectExportedStgBinders
  38
  39         -- and to make the interface self-sufficient...
  40     ) where
  41
  42 import Ubiq{-uitous-}
  43
  44 import CostCentre       ( showCostCentre )
  45 import Id               ( idPrimRep, GenId{-instance NamedThing-} )
  46 import Literal          ( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} )
  47 import Outputable       ( isExported, isOpLexeme, ifPprDebug,
  48                           interppSP, interpp'SP,
  49                           Outputable(..){-instance * Bool-}
  50                         )
  51 import PprStyle         ( PprStyle(..) )
  52 import PprType          ( GenType{-instance Outputable-} )
  53 import Pretty           -- all of it
  54 import PrimOp           ( PrimOp{-instance Outputable-} )
  55 import Unique           ( pprUnique )
  56 import UniqSet          ( isEmptyUniqSet, uniqSetToList, UniqSet(..) )
  57 import Util             ( panic )
  58 \end{code}
  59
  60 %************************************************************************
  61 %*                                                                      *
  62 \subsection{@GenStgBinding@}
  63 %*                                                                      *
  64 %************************************************************************
  65
  66 As usual, expressions are interesting; other things are boring.  Here
  67 are the boring things [except note the @GenStgRhs@], parameterised
  68 with respect to binder and occurrence information (just as in
  69 @CoreSyn@):
  70
  71 \begin{code}
  72 data GenStgBinding bndr occ
  73   = StgNonRec   bndr (GenStgRhs bndr occ)
  74   | StgRec      [(bndr, GenStgRhs bndr occ)]
  75 \end{code}
  76
  77 %************************************************************************
  78 %*                                                                      *
  79 \subsection{@GenStgArg@}
  80 %*                                                                      *
  81 %************************************************************************
  82
  83 \begin{code}
  84 data GenStgArg occ
  85   = StgVarArg   occ
  86   | StgLitArg   Literal
  87 \end{code}
  88
  89 \begin{code}
  90 getArgPrimRep (StgVarArg  local) = idPrimRep local
  91 getArgPrimRep (StgLitArg  lit)   = literalPrimRep lit
  92
  93 isLitLitArg (StgLitArg x) = isLitLitLit x
  94 isLitLitArg _             = False
  95 \end{code}
  96
  97 %************************************************************************
  98 %*                                                                      *
  99 \subsection{STG expressions}
 100 %*                                                                      *
 101 %************************************************************************
 102
 103 The @GenStgExpr@ data type is parameterised on binder and occurrence
 104 info, as before.
 105
 106 %************************************************************************
 107 %*                                                                      *
 108 \subsubsection{@GenStgExpr@ application}
 109 %*                                                                      *
 110 %************************************************************************
 111
 112 An application is of a function to a list of atoms [not expressions].
 113 Operationally, we want to push the arguments on the stack and call the
 114 function.  (If the arguments were expressions, we would have to build
 115 their closures first.)
 116
 117 There is no constructor for a lone variable; it would appear as
 118 @StgApp var [] _@.
 119 \begin{code}
 120 type GenStgLiveVars occ = UniqSet occ
 121
 122 data GenStgExpr bndr occ
 123   = StgApp
 124         (GenStgArg occ) -- function
 125         [GenStgArg occ] -- arguments
 126         (GenStgLiveVars occ)    -- Live vars in continuation; ie not
 127                                 -- including the function and args
 128
 129     -- NB: a literal is: StgApp <lit-atom> [] ...
 130 \end{code}
 131
 132 %************************************************************************
 133 %*                                                                      *
 134 \subsubsection{@StgCon@ and @StgPrim@---saturated applications}
 135 %*                                                                      *
 136 %************************************************************************
 137
 138 There are two specialised forms of application, for
 139 constructors and primitives.
 140 \begin{code}
 141   | StgCon                      -- always saturated
 142         Id -- data constructor
 143         [GenStgArg occ]
 144         (GenStgLiveVars occ)    -- Live vars in continuation; ie not
 145                                 -- including the constr and args
 146
 147   | StgPrim                     -- always saturated
 148         PrimOp
 149         [GenStgArg occ]
 150         (GenStgLiveVars occ)    -- Live vars in continuation; ie not
 151                                 -- including the op and args
 152 \end{code}
 153 These forms are to do ``inline versions,'' as it were.
 154 An example might be: @f x = x:[]@.
 155
 156 %************************************************************************
 157 %*                                                                      *
 158 \subsubsection{@GenStgExpr@: case-expressions}
 159 %*                                                                      *
 160 %************************************************************************
 161
 162 This has the same boxed/unboxed business as Core case expressions.
 163 \begin{code}
 164   | StgCase
 165         (GenStgExpr bndr occ)
 166                         -- the thing to examine
 167
 168         (GenStgLiveVars occ) -- Live vars of whole case
 169                         -- expression; i.e., those which mustn't be
 170                         -- overwritten
 171
 172         (GenStgLiveVars occ) -- Live vars of RHSs;
 173                         -- i.e., those which must be saved before eval.
 174                         --
 175                         -- note that an alt's constructor's
 176                         -- binder-variables are NOT counted in the
 177                         -- free vars for the alt's RHS
 178
 179         Unique          -- Occasionally needed to compile case
 180                         -- statements, as the uniq for a local
 181                         -- variable to hold the tag of a primop with
 182                         -- algebraic result
 183
 184         (GenStgCaseAlts bndr occ)
 185 \end{code}
 186
 187 %************************************************************************
 188 %*                                                                      *
 189 \subsubsection{@GenStgExpr@:  @let(rec)@-expressions}
 190 %*                                                                      *
 191 %************************************************************************
 192
 193 The various forms of let(rec)-expression encode most of the
 194 interesting things we want to do.
 195 \begin{enumerate}
 196 \item
 197 \begin{verbatim}
 198 let-closure x = [free-vars] expr [args]
 199 in e
 200 \end{verbatim}
 201 is equivalent to
 202 \begin{verbatim}
 203 let x = (\free-vars -> \args -> expr) free-vars
 204 \end{verbatim}
 205 \tr{args} may be empty (and is for most closures).  It isn't under
 206 circumstances like this:
 207 \begin{verbatim}
 208 let x = (\y -> y+z)
 209 \end{verbatim}
 210 This gets mangled to
 211 \begin{verbatim}
 212 let-closure x = [z] [y] (y+z)
 213 \end{verbatim}
 214 The idea is that we compile code for @(y+z)@ in an environment in which
 215 @z@ is bound to an offset from \tr{Node}, and @y@ is bound to an
 216 offset from the stack pointer.
 217
 218 (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)
 219
 220 \item
 221 \begin{verbatim}
 222 let-constructor x = Constructor [args]
 223 in e
 224 \end{verbatim}
 225
 226 (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)
 227
 228 \item
 229 Letrec-expressions are essentially the same deal as
 230 let-closure/let-constructor, so we use a common structure and
 231 distinguish between them with an @is_recursive@ boolean flag.
 232
 233 \item
 234 \begin{verbatim}
 235 let-unboxed u = an arbitrary arithmetic expression in unboxed values
 236 in e
 237 \end{verbatim}
 238 All the stuff on the RHS must be fully evaluated.  No function calls either!
 239
 240 (We've backed away from this toward case-expressions with
 241 suitably-magical alts ...)
 242
 243 \item
 244 ~[Advanced stuff here!  Not to start with, but makes pattern matching
 245 generate more efficient code.]
 246
 247 \begin{verbatim}
 248 let-escapes-not fail = expr
 249 in e'
 250 \end{verbatim}
 251 Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,
 252 or pass it to another function.  All @e'@ will ever do is tail-call @fail@.
 253 Rather than build a closure for @fail@, all we need do is to record the stack
 254 level at the moment of the @let-escapes-not@; then entering @fail@ is just
 255 a matter of adjusting the stack pointer back down to that point and entering
 256 the code for it.
 257
 258 Another example:
 259 \begin{verbatim}
 260 f x y = let z = huge-expression in
 261         if y==1 then z else
 262         if y==2 then z else
 263         1
 264 \end{verbatim}
 265
 266 (A let-escapes-not is an @StgLetNoEscape@.)
 267
 268 \item
 269 We may eventually want:
 270 \begin{verbatim}
 271 let-literal x = Literal
 272 in e
 273 \end{verbatim}
 274
 275 (ToDo: is this obsolete?)
 276 \end{enumerate}
 277
 278 And so the code for let(rec)-things:
 279 \begin{code}
 280   | StgLet
 281         (GenStgBinding bndr occ)        -- right hand sides (see below)
 282         (GenStgExpr bndr occ)           -- body
 283
 284   | StgLetNoEscape                      -- remember: ``advanced stuff''
 285         (GenStgLiveVars occ)            -- Live in the whole let-expression
 286                                         -- Mustn't overwrite these stack slots
 287                                         -- *Doesn't* include binders of the let(rec).
 288
 289         (GenStgLiveVars occ)            -- Live in the right hand sides (only)
 290                                         -- These are the ones which must be saved on
 291                                         -- the stack if they aren't there already
 292                                         -- *Does* include binders of the let(rec) if recursive.
 293
 294         (GenStgBinding bndr occ)        -- right hand sides (see below)
 295         (GenStgExpr bndr occ)           -- body
 296 \end{code}
 297
 298 %************************************************************************
 299 %*                                                                      *
 300 \subsubsection{@GenStgExpr@: @scc@ expressions}
 301 %*                                                                      *
 302 %************************************************************************
 303
 304 Finally for @scc@ expressions we introduce a new STG construct.
 305
 306 \begin{code}
 307   | StgSCC
 308         Type                    -- the type of the body
 309         CostCentre              -- label of SCC expression
 310         (GenStgExpr bndr occ)   -- scc expression
 311   -- end of GenStgExpr
 312 \end{code}
 313
 314 %************************************************************************
 315 %*                                                                      *
 316 \subsection{STG right-hand sides}
 317 %*                                                                      *
 318 %************************************************************************
 319
 320 Here's the rest of the interesting stuff for @StgLet@s; the first
 321 flavour is for closures:
 322 \begin{code}
 323 data GenStgRhs bndr occ
 324   = StgRhsClosure
 325         CostCentre              -- cost centre to be attached (default is CCC)
 326         StgBinderInfo           -- Info about how this binder is used (see below)
 327         [occ]                   -- non-global free vars; a list, rather than
 328                                 -- a set, because order is important
 329         UpdateFlag              -- ReEntrant | Updatable | SingleEntry
 330         [bndr]                  -- arguments; if empty, then not a function;
 331                                 -- as above, order is important
 332         (GenStgExpr bndr occ)   -- body
 333 \end{code}
 334 An example may be in order.  Consider:
 335 \begin{verbatim}
 336 let t = \x -> \y -> ... x ... y ... p ... q in e
 337 \end{verbatim}
 338 Pulling out the free vars and stylising somewhat, we get the equivalent:
 339 \begin{verbatim}
 340 let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
 341 \end{verbatim}
 342 Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are
 343 offsets from @Node@ into the closure, and the code ptr for the closure
 344 will be exactly that in parentheses above.
 345
 346 The second flavour of right-hand-side is for constructors (simple but important):
 347 \begin{code}
 348   | StgRhsCon
 349         CostCentre              -- Cost centre to be attached (default is CCC).
 350                                 -- Top-level (static) ones will end up with
 351                                 -- DontCareCC, because we don't count static
 352                                 -- data in heap profiles, and we don't set CCC
 353                                 -- from static closure.
 354         Id                      -- constructor
 355         [GenStgArg occ] -- args
 356 \end{code}
 357
 358 Here's the @StgBinderInfo@ type, and its combining op:
 359 \begin{code}
 360 data StgBinderInfo
 361   = NoStgBinderInfo
 362   | StgBinderInfo
 363         Bool            -- At least one occurrence as an argument
 364
 365         Bool            -- At least one occurrence in an unsaturated application
 366
 367         Bool            -- This thing (f) has at least occurrence of the form:
 368                         --    x = [..] \u [] -> f a b c
 369                         -- where the application is saturated
 370
 371         Bool            -- Ditto for non-updatable x.
 372
 373         Bool            -- At least one fake application occurrence, that is
 374                         -- an StgApp f args where args is an empty list
 375                         -- This is due to the fact that we do not have a
 376                         -- StgVar constructor.
 377                         -- Used by the lambda lifter.
 378                         -- True => "at least one unsat app" is True too
 379
 380 stgArgOcc        = StgBinderInfo True  False False False False
 381 stgUnsatOcc      = StgBinderInfo False True  False False False
 382 stgStdHeapOcc    = StgBinderInfo False False True  False False
 383 stgNoUpdHeapOcc  = StgBinderInfo False False False True  False
 384 stgNormalOcc     = StgBinderInfo False False False False False
 385 -- [Andre] can't think of a good name for the last one.
 386 stgFakeFunAppOcc = StgBinderInfo False True  False False True
 387
 388 combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
 389
 390 combineStgBinderInfo NoStgBinderInfo info2 = info2
 391 combineStgBinderInfo info1 NoStgBinderInfo = info1
 392 combineStgBinderInfo (StgBinderInfo arg1 unsat1 std_heap1 upd_heap1 fkap1)
 393                      (StgBinderInfo arg2 unsat2 std_heap2 upd_heap2 fkap2)
 394   = StgBinderInfo (arg1      || arg2)
 395                   (unsat1    || unsat2)
 396                   (std_heap1 || std_heap2)
 397                   (upd_heap1 || upd_heap2)
 398                   (fkap1     || fkap2)
 399 \end{code}
 400
 401 %************************************************************************
 402 %*                                                                      *
 403 \subsection[Stg-case-alternatives]{STG case alternatives}
 404 %*                                                                      *
 405 %************************************************************************
 406
 407 Just like in @CoreSyntax@ (except no type-world stuff).
 408
 409 \begin{code}
 410 data GenStgCaseAlts bndr occ
 411   = StgAlgAlts  Type    -- so we can find out things about constructor family
 412                 [(Id,                           -- alts: data constructor,
 413                   [bndr],                       -- constructor's parameters,
 414                   [Bool],                       -- "use mask", same length as
 415                                                 -- parameters; a True in a
 416                                                 -- param's position if it is
 417                                                 -- used in the ...
 418                   GenStgExpr bndr occ)] -- ...right-hand side.
 419                 (GenStgCaseDefault bndr occ)
 420   | StgPrimAlts Type    -- so we can find out things about constructor family
 421                 [(Literal,                      -- alts: unboxed literal,
 422                   GenStgExpr bndr occ)] -- rhs.
 423                 (GenStgCaseDefault bndr occ)
 424
 425 data GenStgCaseDefault bndr occ
 426   = StgNoDefault                                -- small con family: all
 427                                                 -- constructor accounted for
 428   | StgBindDefault  bndr                        -- form: var -> expr
 429                     Bool                        -- True <=> var is used in rhs
 430                                                 -- i.e., False <=> "_ -> expr"
 431                     (GenStgExpr bndr occ)
 432 \end{code}
 433
 434 %************************************************************************
 435 %*                                                                      *
 436 \subsection[Stg]{The Plain STG parameterisation}
 437 %*                                                                      *
 438 %************************************************************************
 439
 440 This happens to be the only one we use at the moment.
 441
 442 \begin{code}
 443 type StgBinding     = GenStgBinding     Id Id
 444 type StgArg         = GenStgArg         Id
 445 type StgLiveVars    = GenStgLiveVars    Id
 446 type StgExpr        = GenStgExpr        Id Id
 447 type StgRhs         = GenStgRhs         Id Id
 448 type StgCaseAlts    = GenStgCaseAlts    Id Id
 449 type StgCaseDefault = GenStgCaseDefault Id Id
 450 \end{code}
 451
 452 %************************************************************************
 453 %*                                                                      *
 454 \subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
 455 %*                                                                      *
 456 %************************************************************************
 457
 458 This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
 459
 460 \begin{code}
 461 data UpdateFlag = ReEntrant | Updatable | SingleEntry
 462
 463 instance Outputable UpdateFlag where
 464     ppr sty u
 465       = ppChar (case u of { ReEntrant -> 'r';  Updatable -> 'u';  SingleEntry -> 's' })
 466 \end{code}
 467
 468 %************************************************************************
 469 %*                                                                      *
 470 \subsection[Stg-utility-functions]{Utility functions}
 471 %*                                                                      *
 472 %************************************************************************
 473
 474
 475 For doing interfaces, we want the exported top-level Ids from the
 476 final pre-codegen STG code, so as to be sure we have the
 477 latest/greatest pragma info.
 478
 479 \begin{code}
 480 collectExportedStgBinders
 481         :: [StgBinding] -- input program
 482         -> [Id]                 -- exported top-level Ids
 483
 484 collectExportedStgBinders binds
 485   = ex [] binds
 486   where
 487     ex es [] = es
 488
 489     ex es ((StgNonRec b _) : binds)
 490       = if not (isExported b) then
 491             ex es binds
 492         else
 493             ex (b:es) binds
 494
 495     ex es ((StgRec []) : binds) = ex es binds
 496
 497     ex es ((StgRec ((b, rhs) : pairs)) : binds)
 498       = ex es (StgNonRec b rhs : (StgRec pairs : binds))
 499             -- OK, a total hack; laziness rules
 500 \end{code}
 501
 502 %************************************************************************
 503 %*                                                                      *
 504 \subsection[Stg-pretty-printing]{Pretty-printing}
 505 %*                                                                      *
 506 %************************************************************************
 507
 508 Robin Popplestone asked for semi-colon separators on STG binds; here's
 509 hoping he likes terminators instead...  Ditto for case alternatives.
 510
 511 \begin{code}
 512 pprStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) =>
 513                 PprStyle -> GenStgBinding bndr bdee -> Pretty
 514
 515 pprStgBinding sty (StgNonRec bndr rhs)
 516   = ppHang (ppCat [ppr sty bndr, ppEquals])
 517          4 (ppBeside (ppr sty rhs) ppSemi)
 518
 519 pprStgBinding sty (StgRec pairs)
 520   = ppAboves ((ifPprDebug sty (ppStr "{- StgRec -}")) :
 521               (map (ppr_bind sty) pairs))
 522   where
 523     ppr_bind sty (bndr, expr)
 524       = ppHang (ppCat [ppr sty bndr, ppEquals])
 525              4 (ppBeside (ppr sty expr) ppSemi)
 526
 527 pprPlainStgBinding :: PprStyle -> StgBinding -> Pretty
 528 pprPlainStgBinding sty b = pprStgBinding sty b
 529 \end{code}
 530
 531 \begin{code}
 532 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
 533     ppr = pprStgArg
 534
 535 instance (Outputable bndr, Outputable bdee, Ord bdee)
 536                 => Outputable (GenStgBinding bndr bdee) where
 537     ppr = pprStgBinding
 538
 539 instance (Outputable bndr, Outputable bdee, Ord bdee)
 540                 => Outputable (GenStgExpr bndr bdee) where
 541     ppr = pprStgExpr
 542
 543 instance (Outputable bndr, Outputable bdee, Ord bdee)
 544                 => Outputable (GenStgRhs bndr bdee) where
 545     ppr sty rhs = pprStgRhs sty rhs
 546 \end{code}
 547
 548 \begin{code}
 549 pprStgArg :: (Outputable bdee) => PprStyle -> GenStgArg bdee -> Pretty
 550
 551 pprStgArg sty (StgVarArg var) = ppr sty var
 552 pprStgArg sty (StgLitArg lit) = ppr sty lit
 553 \end{code}
 554
 555 \begin{code}
 556 pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) =>
 557                 PprStyle -> GenStgExpr bndr bdee -> Pretty
 558 -- special case
 559 pprStgExpr sty (StgApp func [] lvs)
 560   = ppBeside (ppr sty func) (pprStgLVs sty lvs)
 561
 562 -- general case
 563 pprStgExpr sty (StgApp func args lvs)
 564   = ppHang (ppBeside (ppr sty func) (pprStgLVs sty lvs))
 565          4 (ppSep (map (ppr sty) args))
 566 \end{code}
 567
 568 \begin{code}
 569 pprStgExpr sty (StgCon con args lvs)
 570   = ppBesides [ ppBeside (ppr sty con) (pprStgLVs sty lvs),
 571                 ppStr "! [", interppSP sty args, ppStr "]" ]
 572
 573 pprStgExpr sty (StgPrim op args lvs)
 574   = ppBesides [ ppr sty op, ppChar '#', pprStgLVs sty lvs,
 575                 ppStr " [", interppSP sty args, ppStr "]" ]
 576 \end{code}
 577
 578 \begin{code}
 579 -- special case: let v = <very specific thing>
 580 --               in
 581 --               let ...
 582 --               in
 583 --               ...
 584 --
 585 -- Very special!  Suspicious! (SLPJ)
 586
 587 pprStgExpr sty (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
 588                         expr@(StgLet _ _))
 589   = ppAbove
 590       (ppHang (ppBesides [ppStr "let { ", ppr sty bndr, ppStr " = ",
 591                           ppStr (showCostCentre sty True{-as string-} cc),
 592                           pp_binder_info sty bi,
 593                           ppStr " [", ifPprDebug sty (interppSP sty free_vars), ppStr "] \\",
 594                           ppr sty upd_flag, ppStr " [",
 595                           interppSP sty args, ppStr "]"])
 596             8 (ppSep [ppCat [ppr sty rhs, ppStr "} in"]]))
 597       (ppr sty expr)
 598
 599 -- special case: let ... in let ...
 600
 601 pprStgExpr sty (StgLet bind expr@(StgLet _ _))
 602   = ppAbove
 603       (ppSep [ppHang (ppStr "let {") 2 (ppCat [pprStgBinding sty bind, ppStr "} in"])])
 604       (ppr sty expr)
 605
 606 -- general case
 607 pprStgExpr sty (StgLet bind expr)
 608   = ppSep [ppHang (ppStr "let {") 2 (pprStgBinding sty bind),
 609            ppHang (ppStr "} in ") 2 (ppr sty expr)]
 610
 611 pprStgExpr sty (StgLetNoEscape lvs_whole lvs_rhss bind expr)
 612   = ppSep [ppHang (ppStr "let-no-escape {")
 613                 2 (pprStgBinding sty bind),
 614            ppHang (ppBeside (ppStr "} in ")
 615                    (ifPprDebug sty (
 616                     ppNest 4 (
 617                       ppBesides [ppStr  "-- lvs: [", interppSP sty (uniqSetToList lvs_whole),
 618                              ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss),
 619                              ppStr "]"]))))
 620                 2 (ppr sty expr)]
 621 \end{code}
 622
 623 \begin{code}
 624 pprStgExpr sty (StgSCC ty cc expr)
 625   = ppSep [ ppCat [ppStr "_scc_", ppStr (showCostCentre sty True{-as string-} cc)],
 626             pprStgExpr sty expr ]
 627 \end{code}
 628
 629 \begin{code}
 630 pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts)
 631   = ppSep [ppSep [ppStr "case",
 632            ppNest 4 (ppCat [pprStgExpr sty expr,
 633              ifPprDebug sty (ppBeside (ppStr "::") (pp_ty alts))]),
 634            ppStr "of {"],
 635            ifPprDebug sty (
 636            ppNest 4 (
 637              ppBesides [ppStr  "-- lvs: [", interppSP sty (uniqSetToList lvs_whole),
 638                     ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss),
 639                     ppStr "]; uniq: ", pprUnique uniq])),
 640            ppNest 2 (ppr_alts sty alts),
 641            ppStr "}"]
 642   where
 643     pp_ty (StgAlgAlts  ty _ _) = ppr sty ty
 644     pp_ty (StgPrimAlts ty _ _) = ppr sty ty
 645
 646     ppr_alts sty (StgAlgAlts ty alts deflt)
 647       = ppAboves [ ppAboves (map (ppr_bxd_alt sty) alts),
 648                    ppr_default sty deflt ]
 649       where
 650         ppr_bxd_alt sty (con, params, use_mask, expr)
 651           = ppHang (ppCat [ppr_con sty con, interppSP sty params, ppStr "->"])
 652                    4 (ppBeside (ppr sty expr) ppSemi)
 653           where
 654             ppr_con sty con
 655               = if isOpLexeme con
 656                 then ppBesides [ppLparen, ppr sty con, ppRparen]
 657                 else ppr sty con
 658
 659     ppr_alts sty (StgPrimAlts ty alts deflt)
 660       = ppAboves [ ppAboves (map (ppr_ubxd_alt sty) alts),
 661                    ppr_default sty deflt ]
 662       where
 663         ppr_ubxd_alt sty (lit, expr)
 664           = ppHang (ppCat [ppr sty lit, ppStr "->"])
 665                  4 (ppBeside (ppr sty expr) ppSemi)
 666
 667     ppr_default sty StgNoDefault = ppNil
 668     ppr_default sty (StgBindDefault bndr used expr)
 669       = ppHang (ppCat [pp_binder, ppStr "->"]) 4 (ppr sty expr)
 670       where
 671         pp_binder = if used then ppr sty bndr else ppChar '_'
 672 \end{code}
 673
 674 \begin{code}
 675 -- pprStgLVs :: PprStyle -> GenStgLiveVars occ -> Pretty
 676
 677 pprStgLVs PprForUser lvs = ppNil
 678
 679 pprStgLVs sty lvs
 680   = if isEmptyUniqSet lvs then
 681         ppNil
 682     else
 683         ppBesides [ppStr "{-lvs:", interpp'SP sty (uniqSetToList lvs), ppStr "-}"]
 684 \end{code}
 685
 686 \begin{code}
 687 pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) =>
 688                 PprStyle -> GenStgRhs bndr bdee -> Pretty
 689
 690 -- special case
 691 pprStgRhs sty (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [] lvs))
 692   = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
 693                 pp_binder_info sty bi,
 694                 ppStr " [", ifPprDebug sty (ppr sty free_var),
 695             ppStr "] \\", ppr sty upd_flag, ppStr " [] ", ppr sty func ]
 696 -- general case
 697 pprStgRhs sty (StgRhsClosure cc bi free_vars upd_flag args body)
 698   = ppHang (ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
 699                 pp_binder_info sty bi,
 700                 ppStr " [", ifPprDebug sty (interppSP sty free_vars),
 701                 ppStr "] \\", ppr sty upd_flag, ppStr " [", interppSP sty args, ppStr "]"])
 702          4 (ppr sty body)
 703
 704 pprStgRhs sty (StgRhsCon cc con args)
 705   = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
 706                 ppSP, ppr sty con, ppStr " [", interppSP sty args, ppStr "]" ]
 707
 708 --------------
 709 pp_binder_info PprForUser _ = ppNil
 710
 711 pp_binder_info sty NoStgBinderInfo = ppNil
 712
 713 -- cases so boring that we print nothing
 714 pp_binder_info sty (StgBinderInfo True b c d e) = ppNil
 715
 716 -- general case
 717 pp_binder_info sty (StgBinderInfo a b c d e)
 718   = ppBesides [ppChar '(', ppInterleave ppComma (map pp_bool [a,b,c,d,e]), ppChar ')']
 719   where
 720     pp_bool x = ppr (panic "pp_bool") x
 721 \end{code}
 722
 723 Collect @IdInfo@ stuff that is most easily just snaffled straight
 724 from the STG bindings.
 725
 726 \begin{code}
 727 stgArity :: StgRhs -> Int
 728
 729 stgArity (StgRhsCon _ _ _)               = 0 -- it's a constructor, fully applied
 730 stgArity (StgRhsClosure _ _ _ _ args _ ) = length args
 731 \end{code}