ghc/compiler/stgSyn/StgSyn.lhs

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