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