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