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 )
  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            | StgFCallOp ForeignCall Unique
 561                 -- The Unique is occasionally needed by the C pretty-printer
 562                 -- (which lacks a unique supply), notably when generating a
 563                 -- typedef for foreign-export-dynamic
 564 \end{code}
 565
 566
 567 %************************************************************************
 568 %*                                                                      *
 569 \subsubsection[Static Reference Tables]{@SRT@}
 570 %*                                                                      *
 571 %************************************************************************
 572
 573 There is one SRT per top-level function group.  Each local binding and
 574 case expression within this binding group has a subrange of the whole
 575 SRT, expressed as an offset and length.
 576
 577 In CoreToStg we collect the list of CafRefs at each SRT site, which is later
 578 converted into the length and offset form by the SRT pass.
 579
 580 \begin{code}
 581 data SRT = NoSRT
 582          | SRTEntries IdSet
 583                 -- generated by CoreToStg
 584          | SRT !Int{-offset-} !Int{-length-} !Bitmap{-bitmap-}
 585                 -- generated by computeSRTs
 586
 587 nonEmptySRT :: SRT -> Bool
 588 nonEmptySRT NoSRT           = False
 589 nonEmptySRT (SRTEntries vs) = not (isEmptyVarSet vs)
 590 nonEmptySRT _               = True
 591
 592 pprSRT :: SRT -> SDoc
 593 pprSRT (NoSRT)          = ptext (sLit "_no_srt_")
 594 pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids
 595 pprSRT (SRT off _ _)    = parens (ppr off <> comma <> text "*bitmap*")
 596 \end{code}
 597
 598 %************************************************************************
 599 %*                                                                      *
 600 \subsection[Stg-pretty-printing]{Pretty-printing}
 601 %*                                                                      *
 602 %************************************************************************
 603
 604 Robin Popplestone asked for semi-colon separators on STG binds; here's
 605 hoping he likes terminators instead...  Ditto for case alternatives.
 606
 607 \begin{code}
 608 pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee)
 609                  => GenStgBinding bndr bdee -> SDoc
 610
 611 pprGenStgBinding (StgNonRec bndr rhs)
 612   = hang (hsep [ppr bndr, equals])
 613         4 ((<>) (ppr rhs) semi)
 614
 615 pprGenStgBinding (StgRec pairs)
 616   = vcat ((ifPprDebug (ptext (sLit "{- StgRec (begin) -}"))) :
 617            (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext (sLit "{- StgRec (end) -}")))])
 618   where
 619     ppr_bind (bndr, expr)
 620       = hang (hsep [ppr bndr, equals])
 621              4 ((<>) (ppr expr) semi)
 622
 623 pprStgBinding  :: StgBinding -> SDoc
 624 pprStgBinding  bind  = pprGenStgBinding bind
 625
 626 pprStgBindings :: [StgBinding] -> SDoc
 627 pprStgBindings binds = vcat (map pprGenStgBinding binds)
 628
 629 pprGenStgBindingWithSRT
 630         :: (Outputable bndr, Outputable bdee, Ord bdee)
 631         => (GenStgBinding bndr bdee,[(Id,[Id])]) -> SDoc
 632
 633 pprGenStgBindingWithSRT (bind,srts)
 634   = vcat (pprGenStgBinding bind : map pprSRT srts)
 635   where pprSRT (id,srt) =
 636            ptext (sLit "SRT") <> parens (ppr id) <> ptext (sLit ": ") <> ppr srt
 637
 638 pprStgBindingsWithSRTs :: [(StgBinding,[(Id,[Id])])] -> SDoc
 639 pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds)
 640 \end{code}
 641
 642 \begin{code}
 643 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
 644     ppr = pprStgArg
 645
 646 instance (Outputable bndr, Outputable bdee, Ord bdee)
 647                 => Outputable (GenStgBinding bndr bdee) where
 648     ppr = pprGenStgBinding
 649
 650 instance (Outputable bndr, Outputable bdee, Ord bdee)
 651                 => Outputable (GenStgExpr bndr bdee) where
 652     ppr = pprStgExpr
 653
 654 instance (Outputable bndr, Outputable bdee, Ord bdee)
 655                 => Outputable (GenStgRhs bndr bdee) where
 656     ppr rhs = pprStgRhs rhs
 657 \end{code}
 658
 659 \begin{code}
 660 pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
 661
 662 pprStgArg (StgVarArg var) = ppr var
 663 pprStgArg (StgLitArg con) = ppr con
 664 pprStgArg (StgTypeArg ty) = char '@' <+> ppr ty
 665 \end{code}
 666
 667 \begin{code}
 668 pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee)
 669            => GenStgExpr bndr bdee -> SDoc
 670 -- special case
 671 pprStgExpr (StgLit lit)     = ppr lit
 672
 673 -- general case
 674 pprStgExpr (StgApp func args)
 675   = hang (ppr func)
 676          4 (sep (map (ppr) args))
 677 \end{code}
 678
 679 \begin{code}
 680 pprStgExpr (StgConApp con args)
 681   = hsep [ ppr con, brackets (interppSP args)]
 682
 683 pprStgExpr (StgOpApp op args _)
 684   = hsep [ pprStgOp op, brackets (interppSP args)]
 685
 686 pprStgExpr (StgLam _ bndrs body)
 687   =sep [ char '\\' <+> ppr bndrs <+> ptext (sLit "->"),
 688          pprStgExpr body ]
 689 \end{code}
 690
 691 \begin{code}
 692 -- special case: let v = <very specific thing>
 693 --               in
 694 --               let ...
 695 --               in
 696 --               ...
 697 --
 698 -- Very special!  Suspicious! (SLPJ)
 699
 700 {-
 701 pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
 702                         expr@(StgLet _ _))
 703   = ($$)
 704       (hang (hcat [ptext (sLit "let { "), ppr bndr, ptext (sLit " = "),
 705                           ppr cc,
 706                           pp_binder_info bi,
 707                           ptext (sLit " ["), ifPprDebug (interppSP free_vars), ptext (sLit "] \\"),
 708                           ppr upd_flag, ptext (sLit " ["),
 709                           interppSP args, char ']'])
 710             8 (sep [hsep [ppr rhs, ptext (sLit "} in")]]))
 711       (ppr expr)
 712 -}
 713
 714 -- special case: let ... in let ...
 715
 716 pprStgExpr (StgLet bind expr@(StgLet _ _))
 717   = ($$)
 718       (sep [hang (ptext (sLit "let {"))
 719                 2 (hsep [pprGenStgBinding bind, ptext (sLit "} in")])])
 720       (ppr expr)
 721
 722 -- general case
 723 pprStgExpr (StgLet bind expr)
 724   = sep [hang (ptext (sLit "let {")) 2 (pprGenStgBinding bind),
 725            hang (ptext (sLit "} in ")) 2 (ppr expr)]
 726
 727 pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr)
 728   = sep [hang (ptext (sLit "let-no-escape {"))
 729                 2 (pprGenStgBinding bind),
 730            hang ((<>) (ptext (sLit "} in "))
 731                    (ifPprDebug (
 732                     nest 4 (
 733                       hcat [ptext  (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole),
 734                              ptext (sLit "]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
 735                              char ']']))))
 736                 2 (ppr expr)]
 737
 738 pprStgExpr (StgSCC cc expr)
 739   = sep [ hsep [ptext (sLit "_scc_"), ppr cc],
 740           pprStgExpr expr ]
 741
 742 pprStgExpr (StgTick m n expr)
 743   = sep [ hsep [ptext (sLit "_tick_"),  pprModule m,text (show n)],
 744           pprStgExpr expr ]
 745
 746 pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts)
 747   = sep [sep [ptext (sLit "case"),
 748            nest 4 (hsep [pprStgExpr expr,
 749              ifPprDebug (dcolon <+> ppr alt_type)]),
 750            ptext (sLit "of"), ppr bndr, char '{'],
 751            ifPprDebug (
 752            nest 4 (
 753              hcat [ptext  (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole),
 754                     ptext (sLit "]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
 755                     ptext (sLit "]; "),
 756                     pprMaybeSRT srt])),
 757            nest 2 (vcat (map pprStgAlt alts)),
 758            char '}']
 759
 760 pprStgAlt :: (Outputable bndr, Outputable occ, Ord occ)
 761           => GenStgAlt bndr occ -> SDoc
 762 pprStgAlt (con, params, _use_mask, expr)
 763   = hang (hsep [ppr con, interppSP params, ptext (sLit "->")])
 764          4 (ppr expr <> semi)
 765
 766 pprStgOp :: StgOp -> SDoc
 767 pprStgOp (StgPrimOp  op)   = ppr op
 768 pprStgOp (StgFCallOp op _) = ppr op
 769
 770 instance Outputable AltType where
 771   ppr PolyAlt        = ptext (sLit "Polymorphic")
 772   ppr (UbxTupAlt tc) = ptext (sLit "UbxTup") <+> ppr tc
 773   ppr (AlgAlt tc)    = ptext (sLit "Alg")    <+> ppr tc
 774   ppr (PrimAlt tc)   = ptext (sLit "Prim")   <+> ppr tc
 775 \end{code}
 776
 777 \begin{code}
 778 #ifdef DEBUG
 779 pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
 780 pprStgLVs lvs
 781   = getPprStyle $ \ sty ->
 782     if userStyle sty || isEmptyUniqSet lvs then
 783         empty
 784     else
 785         hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
 786 #endif
 787 \end{code}
 788
 789 \begin{code}
 790 pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee)
 791           => GenStgRhs bndr bdee -> SDoc
 792
 793 -- special case
 794 pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag srt [{-no args-}] (StgApp func []))
 795   = hcat [ ppr cc,
 796            pp_binder_info bi,
 797            brackets (ifPprDebug (ppr free_var)),
 798            ptext (sLit " \\"), ppr upd_flag, pprMaybeSRT srt, ptext (sLit " [] "), ppr func ]
 799
 800 -- general case
 801 pprStgRhs (StgRhsClosure cc bi free_vars upd_flag srt args body)
 802   = hang (hsep [if opt_SccProfilingOn then ppr cc else empty,
 803                 pp_binder_info bi,
 804                 ifPprDebug (brackets (interppSP free_vars)),
 805                 char '\\' <> ppr upd_flag, pprMaybeSRT srt, brackets (interppSP args)])
 806          4 (ppr body)
 807
 808 pprStgRhs (StgRhsCon cc con args)
 809   = hcat [ ppr cc,
 810            space, ppr con, ptext (sLit "! "), brackets (interppSP args)]
 811
 812 pprMaybeSRT :: SRT -> SDoc
 813 pprMaybeSRT (NoSRT) = empty
 814 pprMaybeSRT srt     = ptext (sLit "srt:") <> pprSRT srt
 815 \end{code}