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