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