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