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 A @ReEntrant@ closure may be entered multiple times, but should not be
 449 updated or blackholed.  An @Updatable@ closure should be updated after
 450 evaluation (and may be blackholed during evaluation).  A @SingleEntry@
 451 closure will only be entered once, and so need not be updated but may
 452 safely be blackholed.
 453
 454 \begin{code}
 455 data UpdateFlag = ReEntrant | Updatable | SingleEntry
 456
 457 instance Outputable UpdateFlag where
 458     ppr u
 459       = char (case u of { ReEntrant -> 'r';  Updatable -> 'u';  SingleEntry -> 's' })
 460
 461 isUpdatable ReEntrant   = False
 462 isUpdatable SingleEntry = False
 463 isUpdatable Updatable   = True
 464 \end{code}
 465
 466 %************************************************************************
 467 %*                                                                      *
 468 \subsubsection[Static Reference Tables]{@SRT@}
 469 %*                                                                      *
 470 %************************************************************************
 471
 472 There is one SRT per top-level function group.  Each local binding and
 473 case expression within this binding group has a subrange of the whole
 474 SRT, expressed as an offset and length.
 475
 476 \begin{code}
 477 data SRT = NoSRT
 478          | SRT !Int{-offset-} !Int{-length-}
 479
 480 noSRT :: SRT
 481 noSRT = NoSRT
 482
 483 pprSRT (NoSRT) = ptext SLIT("_no_srt_")
 484 pprSRT (SRT off len) = parens (ppr off <> comma <> ppr len)
 485 \end{code}
 486
 487 %************************************************************************
 488 %*                                                                      *
 489 \subsection[Stg-utility-functions]{Utility functions}
 490 %*                                                                      *
 491 %************************************************************************
 492
 493
 494 For doing interfaces, we want the exported top-level Ids from the
 495 final pre-codegen STG code, so as to be sure we have the
 496 latest/greatest pragma info.
 497
 498 \begin{code}
 499 collectFinalStgBinders
 500         :: [StgBinding] -- input program
 501         -> [Id]
 502
 503 collectFinalStgBinders [] = []
 504 collectFinalStgBinders (StgNonRec b _ : binds) = b : collectFinalStgBinders binds
 505 collectFinalStgBinders (StgRec bs     : binds) = map fst bs ++ collectFinalStgBinders binds
 506 \end{code}
 507
 508 %************************************************************************
 509 %*                                                                      *
 510 \subsection[Stg-pretty-printing]{Pretty-printing}
 511 %*                                                                      *
 512 %************************************************************************
 513
 514 Robin Popplestone asked for semi-colon separators on STG binds; here's
 515 hoping he likes terminators instead...  Ditto for case alternatives.
 516
 517 \begin{code}
 518 pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee)
 519                  => GenStgBinding bndr bdee -> SDoc
 520
 521 pprGenStgBinding (StgNonRec bndr rhs)
 522   = hang (hsep [ppr bndr, equals])
 523          4 ((<>) (ppr rhs) semi)
 524
 525 pprGenStgBinding (StgRec pairs)
 526   = vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) :
 527               (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))])
 528   where
 529     ppr_bind (bndr, expr)
 530       = hang (hsep [ppr bndr, equals])
 531              4 ((<>) (ppr expr) semi)
 532
 533 pprStgBinding  :: StgBinding -> SDoc
 534 pprStgBinding  bind  = pprGenStgBinding bind
 535
 536 pprStgBindings :: [StgBinding] -> SDoc
 537 pprStgBindings binds = vcat (map pprGenStgBinding binds)
 538
 539 pprGenStgBindingWithSRT
 540         :: (Outputable bndr, Outputable bdee, Ord bdee)
 541         => (GenStgBinding bndr bdee,[Id]) -> SDoc
 542
 543 pprGenStgBindingWithSRT (bind,srt)
 544   = vcat [ pprGenStgBinding bind,
 545            ptext SLIT("SRT: ") <> ppr srt ]
 546
 547 pprStgBindingsWithSRTs :: [(StgBinding,[Id])] -> SDoc
 548 pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds)
 549 \end{code}
 550
 551 \begin{code}
 552 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
 553     ppr = pprStgArg
 554
 555 instance (Outputable bndr, Outputable bdee, Ord bdee)
 556                 => Outputable (GenStgBinding bndr bdee) where
 557     ppr = pprGenStgBinding
 558
 559 instance (Outputable bndr, Outputable bdee, Ord bdee)
 560                 => Outputable (GenStgExpr bndr bdee) where
 561     ppr = pprStgExpr
 562
 563 instance (Outputable bndr, Outputable bdee, Ord bdee)
 564                 => Outputable (GenStgRhs bndr bdee) where
 565     ppr rhs = pprStgRhs rhs
 566 \end{code}
 567
 568 \begin{code}
 569 pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
 570
 571 pprStgArg (StgVarArg var) = ppr var
 572 pprStgArg (StgConArg con) = ppr con
 573 \end{code}
 574
 575 \begin{code}
 576 pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee)
 577            => GenStgExpr bndr bdee -> SDoc
 578 -- special case
 579 pprStgExpr (StgApp func []) = ppr func
 580
 581 -- general case
 582 pprStgExpr (StgApp func args)
 583   = hang (ppr func)
 584          4 (sep (map (ppr) args))
 585 \end{code}
 586
 587 \begin{code}
 588 pprStgExpr (StgCon con args _)
 589   = hsep [ ppr con, brackets (interppSP args)]
 590 \end{code}
 591
 592 \begin{code}
 593 -- special case: let v = <very specific thing>
 594 --               in
 595 --               let ...
 596 --               in
 597 --               ...
 598 --
 599 -- Very special!  Suspicious! (SLPJ)
 600
 601 pprStgExpr (StgLet (StgNonRec bndr (StgRhsClosure cc bi srt free_vars upd_flag args rhs))
 602                         expr@(StgLet _ _))
 603   = ($$)
 604       (hang (hcat [ptext SLIT("let { "), ppr bndr, ptext SLIT(" = "),
 605                           ppr cc,
 606                           pp_binder_info bi,
 607                           ptext SLIT(" ["), ifPprDebug (interppSP free_vars), ptext SLIT("] \\"),
 608                           ppr upd_flag, ptext SLIT(" ["),
 609                           interppSP args, char ']'])
 610             8 (sep [hsep [ppr rhs, ptext SLIT("} in")]]))
 611       (ppr expr)
 612
 613 -- special case: let ... in let ...
 614
 615 pprStgExpr (StgLet bind expr@(StgLet _ _))
 616   = ($$)
 617       (sep [hang (ptext SLIT("let {")) 2 (hsep [pprGenStgBinding bind, ptext SLIT("} in")])])
 618       (ppr expr)
 619
 620 -- general case
 621 pprStgExpr (StgLet bind expr)
 622   = sep [hang (ptext SLIT("let {")) 2 (pprGenStgBinding bind),
 623            hang (ptext SLIT("} in ")) 2 (ppr expr)]
 624
 625 pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr)
 626   = sep [hang (ptext SLIT("let-no-escape {"))
 627                 2 (pprGenStgBinding bind),
 628            hang ((<>) (ptext SLIT("} in "))
 629                    (ifPprDebug (
 630                     nest 4 (
 631                       hcat [ptext  SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
 632                              ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
 633                              char ']']))))
 634                 2 (ppr expr)]
 635 \end{code}
 636
 637 \begin{code}
 638 pprStgExpr (StgSCC cc expr)
 639   = sep [ hsep [ptext SLIT("_scc_"), ppr cc],
 640           pprStgExpr expr ]
 641 \end{code}
 642
 643 \begin{code}
 644 pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alts)
 645   = sep [sep [ptext SLIT("case"),
 646            nest 4 (hsep [pprStgExpr expr,
 647              ifPprDebug (dcolon <+> pp_ty alts)]),
 648            ptext SLIT("of"), ppr bndr, char '{'],
 649            ifPprDebug (
 650            nest 4 (
 651              hcat [ptext  SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
 652                     ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
 653                     ptext SLIT("]; "),
 654                     pprMaybeSRT srt])),
 655            nest 2 (ppr_alts alts),
 656            char '}']
 657   where
 658     ppr_default StgNoDefault = empty
 659     ppr_default (StgBindDefault expr)
 660       = hang (hsep [ptext SLIT("DEFAULT"), ptext SLIT("->")]) 4 (ppr expr)
 661
 662     pp_ty (StgAlgAlts  ty _ _) = ppr ty
 663     pp_ty (StgPrimAlts ty _ _) = ppr ty
 664
 665     ppr_alts (StgAlgAlts ty alts deflt)
 666       = vcat [ vcat (map (ppr_bxd_alt) alts),
 667                    ppr_default deflt ]
 668       where
 669         ppr_bxd_alt (con, params, use_mask, expr)
 670           = hang (hsep [ppr con, interppSP params, ptext SLIT("->")])
 671                    4 ((<>) (ppr expr) semi)
 672
 673     ppr_alts (StgPrimAlts ty alts deflt)
 674       = vcat [ vcat (map (ppr_ubxd_alt) alts),
 675                    ppr_default deflt ]
 676       where
 677         ppr_ubxd_alt (lit, expr)
 678           = hang (hsep [ppr lit, ptext SLIT("->")])
 679                  4 ((<>) (ppr expr) semi)
 680 \end{code}
 681
 682 \begin{code}
 683 pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
 684 pprStgLVs lvs
 685   = getPprStyle $ \ sty ->
 686     if userStyle sty || isEmptyUniqSet lvs then
 687         empty
 688     else
 689         hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
 690 \end{code}
 691
 692 \begin{code}
 693 pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee)
 694           => GenStgRhs bndr bdee -> SDoc
 695
 696 -- special case
 697 pprStgRhs (StgRhsClosure cc bi srt [free_var] upd_flag [{-no args-}] (StgApp func []))
 698   = hcat [ ppr cc,
 699            pp_binder_info bi,
 700            pprMaybeSRT srt,
 701            brackets (ifPprDebug (ppr free_var)),
 702            ptext SLIT(" \\"), ppr upd_flag, ptext SLIT(" [] "), ppr func ]
 703
 704 -- general case
 705 pprStgRhs (StgRhsClosure cc bi srt free_vars upd_flag args body)
 706   = hang (hcat [ppr cc,
 707                 pp_binder_info bi,
 708                 pprMaybeSRT srt,
 709                 brackets (ifPprDebug (interppSP free_vars)),
 710                 ptext SLIT(" \\"), ppr upd_flag, brackets (interppSP args)])
 711          4 (ppr body)
 712
 713 pprStgRhs (StgRhsCon cc con args)
 714   = hcat [ ppr cc,
 715            space, ppr con, ptext SLIT("! "), brackets (interppSP args)]
 716
 717 pprMaybeSRT (NoSRT) = empty
 718 pprMaybeSRT srt     = ptext SLIT(" srt: ") <> pprSRT srt
 719
 720 --------------
 721
 722 pp_binder_info NoStgBinderInfo = empty
 723
 724 -- cases so boring that we print nothing
 725 pp_binder_info (StgBinderInfo True b c d e) = empty
 726
 727 -- general case
 728 pp_binder_info (StgBinderInfo a b c d e)
 729   = getPprStyle $ \ sty ->
 730     if userStyle sty then
 731        empty
 732     else
 733        parens (hsep (punctuate comma (map ppr [a,b,c,d,e])))
 734 \end{code}
 735
 736 Collect @IdInfo@ stuff that is most easily just snaffled straight
 737 from the STG bindings.
 738
 739 \begin{code}
 740 stgArity :: StgRhs -> Int
 741
 742 stgArity (StgRhsCon _ _ _)               = 0 -- it's a constructor, fully applied
 743 stgArity (StgRhsClosure _ _ _ _ _ args _ ) = length args
 744 \end{code}