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