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