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