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