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