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, pprStgAlts,
  36         isLitLitArg, isDllConApp, isStgTypeArg,
  37         stgArity, stgArgType
  38
  39 #ifdef DEBUG
  40         , pprStgLVs
  41 #endif
  42     ) where
  43
  44 #include "HsVersions.h"
  45
  46 import CostCentre       ( CostCentreStack, CostCentre )
  47 import Id               ( Id, idName, idPrimRep, idType )
  48 import Name             ( isDllName )
  49 import Literal          ( Literal, literalType, isLitLitLit, literalPrimRep )
  50 import DataCon          ( DataCon, dataConName )
  51 import PrimOp           ( PrimOp )
  52 import Outputable
  53 import Type             ( Type )
  54 import TyCon            ( TyCon )
  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 * Algebraic cases are done using
 436         StgAlgAlts (Just tc) alts deflt
 437
 438 * Polymorphic cases, or case of a function type, are done using
 439         StgAlgAlts Nothing [] (StgBindDefault e)
 440
 441 * Primitive cases are done using
 442         StgPrimAlts tc alts deflt
 443
 444 We thought of giving polymorphic cases their own constructor,
 445 but we get a bit more code sharing this way
 446
 447 The type constructor in StgAlgAlts/StgPrimAlts is guaranteed not
 448 to be abstract; that is, we can see its representation.  This is
 449 important because the code generator uses it to determine return
 450 conventions etc.  But it's not trivial where there's a moduule loop
 451 involved, because some versions of a type constructor might not have
 452 all the constructors visible.  So mkStgAlgAlts (in CoreToStg) ensures
 453 that it gets the TyCon from the constructors or literals (which are
 454 guaranteed to have the Real McCoy) rather than from the scrutinee type.
 455
 456 \begin{code}
 457 data GenStgCaseAlts bndr occ
 458   = StgAlgAlts  (Maybe TyCon)                   -- Just tc => scrutinee type is
 459                                                 --            an algebraic data type
 460                                                 -- Nothing => scrutinee type is a type
 461                                                 --            variable or function type
 462                 [(DataCon,                      -- alts: data constructor,
 463                   [bndr],                       -- constructor's parameters,
 464                   [Bool],                       -- "use mask", same length as
 465                                                 -- parameters; a True in a
 466                                                 -- param's position if it is
 467                                                 -- used in the ...
 468                   GenStgExpr bndr occ)] -- ...right-hand side.
 469                 (GenStgCaseDefault bndr occ)
 470
 471   | StgPrimAlts TyCon
 472                 [(Literal,                      -- alts: unboxed literal,
 473                   GenStgExpr bndr occ)] -- rhs.
 474                 (GenStgCaseDefault bndr occ)
 475
 476 data GenStgCaseDefault bndr occ
 477   = StgNoDefault                                -- small con family: all
 478                                                 -- constructor accounted for
 479   | StgBindDefault (GenStgExpr bndr occ)
 480 \end{code}
 481
 482 %************************************************************************
 483 %*                                                                      *
 484 \subsection[Stg]{The Plain STG parameterisation}
 485 %*                                                                      *
 486 %************************************************************************
 487
 488 This happens to be the only one we use at the moment.
 489
 490 \begin{code}
 491 type StgBinding     = GenStgBinding     Id Id
 492 type StgArg         = GenStgArg         Id
 493 type StgLiveVars    = GenStgLiveVars    Id
 494 type StgExpr        = GenStgExpr        Id Id
 495 type StgRhs         = GenStgRhs         Id Id
 496 type StgCaseAlts    = GenStgCaseAlts    Id Id
 497 type StgCaseDefault = GenStgCaseDefault Id Id
 498 \end{code}
 499
 500 %************************************************************************
 501 %*                                                                      *
 502 \subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
 503 %*                                                                      *
 504 %************************************************************************
 505
 506 This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
 507
 508 A @ReEntrant@ closure may be entered multiple times, but should not be
 509 updated or blackholed.  An @Updatable@ closure should be updated after
 510 evaluation (and may be blackholed during evaluation).  A @SingleEntry@
 511 closure will only be entered once, and so need not be updated but may
 512 safely be blackholed.
 513
 514 \begin{code}
 515 data UpdateFlag = ReEntrant | Updatable | SingleEntry
 516
 517 instance Outputable UpdateFlag where
 518     ppr u
 519       = char (case u of { ReEntrant -> 'r';  Updatable -> 'u';  SingleEntry -> 's' })
 520
 521 isUpdatable ReEntrant   = False
 522 isUpdatable SingleEntry = False
 523 isUpdatable Updatable   = True
 524 \end{code}
 525
 526 %************************************************************************
 527 %*                                                                      *
 528 \subsubsection[Static Reference Tables]{@SRT@}
 529 %*                                                                      *
 530 %************************************************************************
 531
 532 There is one SRT per top-level function group.  Each local binding and
 533 case expression within this binding group has a subrange of the whole
 534 SRT, expressed as an offset and length.
 535
 536 \begin{code}
 537 data SRT = NoSRT
 538          | SRT !Int{-offset-} !Int{-length-}
 539
 540 noSRT :: SRT
 541 noSRT = NoSRT
 542
 543 pprSRT (NoSRT) = ptext SLIT("_no_srt_")
 544 pprSRT (SRT off len) = parens (ppr off <> comma <> ppr len)
 545 \end{code}
 546
 547 %************************************************************************
 548 %*                                                                      *
 549 \subsection[Stg-pretty-printing]{Pretty-printing}
 550 %*                                                                      *
 551 %************************************************************************
 552
 553 Robin Popplestone asked for semi-colon separators on STG binds; here's
 554 hoping he likes terminators instead...  Ditto for case alternatives.
 555
 556 \begin{code}
 557 pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee)
 558                  => GenStgBinding bndr bdee -> SDoc
 559
 560 pprGenStgBinding (StgNonRec bndr rhs)
 561   = hang (hsep [ppr bndr, equals])
 562          4 ((<>) (ppr rhs) semi)
 563
 564 pprGenStgBinding (StgRec pairs)
 565   = vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) :
 566               (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))])
 567   where
 568     ppr_bind (bndr, expr)
 569       = hang (hsep [ppr bndr, equals])
 570              4 ((<>) (ppr expr) semi)
 571
 572 pprStgBinding  :: StgBinding -> SDoc
 573 pprStgBinding  bind  = pprGenStgBinding bind
 574
 575 pprStgBindings :: [StgBinding] -> SDoc
 576 pprStgBindings binds = vcat (map pprGenStgBinding binds)
 577
 578 pprGenStgBindingWithSRT
 579         :: (Outputable bndr, Outputable bdee, Ord bdee)
 580         => (GenStgBinding bndr bdee,[Id]) -> SDoc
 581
 582 pprGenStgBindingWithSRT (bind,srt)
 583   = vcat [ pprGenStgBinding bind,
 584            ptext SLIT("SRT: ") <> ppr srt ]
 585
 586 pprStgBindingsWithSRTs :: [(StgBinding,[Id])] -> SDoc
 587 pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds)
 588 \end{code}
 589
 590 \begin{code}
 591 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
 592     ppr = pprStgArg
 593
 594 instance (Outputable bndr, Outputable bdee, Ord bdee)
 595                 => Outputable (GenStgBinding bndr bdee) where
 596     ppr = pprGenStgBinding
 597
 598 instance (Outputable bndr, Outputable bdee, Ord bdee)
 599                 => Outputable (GenStgExpr bndr bdee) where
 600     ppr = pprStgExpr
 601
 602 instance (Outputable bndr, Outputable bdee, Ord bdee)
 603                 => Outputable (GenStgRhs bndr bdee) where
 604     ppr rhs = pprStgRhs rhs
 605 \end{code}
 606
 607 \begin{code}
 608 pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
 609
 610 pprStgArg (StgVarArg var) = ppr var
 611 pprStgArg (StgLitArg con) = ppr con
 612 pprStgArg (StgTypeArg ty) = char '@' <+> ppr ty
 613 \end{code}
 614
 615 \begin{code}
 616 pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee)
 617            => GenStgExpr bndr bdee -> SDoc
 618 -- special case
 619 pprStgExpr (StgLit lit)     = ppr lit
 620
 621 -- general case
 622 pprStgExpr (StgApp func args)
 623   = hang (ppr func)
 624          4 (sep (map (ppr) args))
 625 \end{code}
 626
 627 \begin{code}
 628 pprStgExpr (StgConApp con args)
 629   = hsep [ ppr con, brackets (interppSP args)]
 630
 631 pprStgExpr (StgPrimApp op args _)
 632   = hsep [ ppr op, brackets (interppSP args)]
 633
 634 pprStgExpr (StgLam _ bndrs body)
 635   =sep [ char '\\' <+> ppr bndrs <+> ptext SLIT("->"),
 636          pprStgExpr body ]
 637 \end{code}
 638
 639 \begin{code}
 640 -- special case: let v = <very specific thing>
 641 --               in
 642 --               let ...
 643 --               in
 644 --               ...
 645 --
 646 -- Very special!  Suspicious! (SLPJ)
 647
 648 pprStgExpr (StgLet (StgNonRec bndr (StgRhsClosure cc bi srt free_vars upd_flag args rhs))
 649                         expr@(StgLet _ _))
 650   = ($$)
 651       (hang (hcat [ptext SLIT("let { "), ppr bndr, ptext SLIT(" = "),
 652                           ppr cc,
 653                           pp_binder_info bi,
 654                           ptext SLIT(" ["), ifPprDebug (interppSP free_vars), ptext SLIT("] \\"),
 655                           ppr upd_flag, ptext SLIT(" ["),
 656                           interppSP args, char ']'])
 657             8 (sep [hsep [ppr rhs, ptext SLIT("} in")]]))
 658       (ppr expr)
 659
 660 -- special case: let ... in let ...
 661
 662 pprStgExpr (StgLet bind expr@(StgLet _ _))
 663   = ($$)
 664       (sep [hang (ptext SLIT("let {")) 2 (hsep [pprGenStgBinding bind, ptext SLIT("} in")])])
 665       (ppr expr)
 666
 667 -- general case
 668 pprStgExpr (StgLet bind expr)
 669   = sep [hang (ptext SLIT("let {")) 2 (pprGenStgBinding bind),
 670            hang (ptext SLIT("} in ")) 2 (ppr expr)]
 671
 672 pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr)
 673   = sep [hang (ptext SLIT("let-no-escape {"))
 674                 2 (pprGenStgBinding bind),
 675            hang ((<>) (ptext SLIT("} in "))
 676                    (ifPprDebug (
 677                     nest 4 (
 678                       hcat [ptext  SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
 679                              ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
 680                              char ']']))))
 681                 2 (ppr expr)]
 682 \end{code}
 683
 684 \begin{code}
 685 pprStgExpr (StgSCC cc expr)
 686   = sep [ hsep [ptext SLIT("_scc_"), ppr cc],
 687           pprStgExpr expr ]
 688 \end{code}
 689
 690 \begin{code}
 691 pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alts)
 692   = sep [sep [ptext SLIT("case"),
 693            nest 4 (hsep [pprStgExpr expr,
 694              ifPprDebug (dcolon <+> pp_ty alts)]),
 695            ptext SLIT("of"), ppr bndr, char '{'],
 696            ifPprDebug (
 697            nest 4 (
 698              hcat [ptext  SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
 699                     ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
 700                     ptext SLIT("]; "),
 701                     pprMaybeSRT srt])),
 702            nest 2 (pprStgAlts alts),
 703            char '}']
 704   where
 705     pp_ty (StgAlgAlts  maybe_tycon _ _) = ppr maybe_tycon
 706     pp_ty (StgPrimAlts tycon       _ _) = ppr tycon
 707
 708 pprStgAlts (StgAlgAlts _ alts deflt)
 709       = vcat [ vcat (map (ppr_bxd_alt) alts),
 710                pprStgDefault 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 pprStgAlts (StgPrimAlts _ alts deflt)
 717       = vcat [ vcat (map (ppr_ubxd_alt) alts),
 718                pprStgDefault deflt ]
 719       where
 720         ppr_ubxd_alt (lit, expr)
 721           = hang (hsep [ppr lit, ptext SLIT("->")])
 722                  4 ((<>) (ppr expr) semi)
 723
 724 pprStgDefault StgNoDefault          = empty
 725 pprStgDefault (StgBindDefault expr) = hang (hsep [ptext SLIT("DEFAULT"), ptext SLIT("->")])
 726                                          4 (ppr expr)
 727
 728 \end{code}
 729
 730 \begin{code}
 731 pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
 732 pprStgLVs lvs
 733   = getPprStyle $ \ sty ->
 734     if userStyle sty || isEmptyUniqSet lvs then
 735         empty
 736     else
 737         hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
 738 \end{code}
 739
 740 \begin{code}
 741 pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee)
 742           => GenStgRhs bndr bdee -> SDoc
 743
 744 -- special case
 745 pprStgRhs (StgRhsClosure cc bi srt [free_var] upd_flag [{-no args-}] (StgApp func []))
 746   = hcat [ ppr cc,
 747            pp_binder_info bi,
 748            pprMaybeSRT srt,
 749            brackets (ifPprDebug (ppr free_var)),
 750            ptext SLIT(" \\"), ppr upd_flag, ptext SLIT(" [] "), ppr func ]
 751
 752 -- general case
 753 pprStgRhs (StgRhsClosure cc bi srt free_vars upd_flag args body)
 754   = hang (hcat [ppr cc,
 755                 pp_binder_info bi,
 756                 pprMaybeSRT srt,
 757                 brackets (ifPprDebug (interppSP free_vars)),
 758                 ptext SLIT(" \\"), ppr upd_flag, brackets (interppSP args)])
 759          4 (ppr body)
 760
 761 pprStgRhs (StgRhsCon cc con args)
 762   = hcat [ ppr cc,
 763            space, ppr con, ptext SLIT("! "), brackets (interppSP args)]
 764
 765 pprMaybeSRT (NoSRT) = empty
 766 pprMaybeSRT srt     = ptext SLIT(" srt: ") <> pprSRT srt
 767
 768 --------------
 769
 770 pp_binder_info NoStgBinderInfo = empty
 771
 772 -- cases so boring that we print nothing
 773 pp_binder_info (StgBinderInfo True b c d e) = empty
 774
 775 -- general case
 776 pp_binder_info (StgBinderInfo a b c d e)
 777   = getPprStyle $ \ sty ->
 778     if userStyle sty then
 779        empty
 780     else
 781        parens (hsep (punctuate comma (map ppr [a,b,c,d,e])))
 782 \end{code}
 783
 784 Collect @IdInfo@ stuff that is most easily just snaffled straight
 785 from the STG bindings.
 786
 787 \begin{code}
 788 stgArity :: StgRhs -> Int
 789
 790 stgArity (StgRhsCon _ _ _)               = 0 -- it's a constructor, fully applied
 791 stgArity (StgRhsClosure _ _ _ _ _ args _ ) = length args
 792 \end{code}