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