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