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 PackageConfig    ( PackageId )
  56 import Literal          ( Literal, literalType )
  57 import ForeignCall      ( ForeignCall )
  58 import DataCon          ( DataCon, dataConName )
  59 import CoreSyn          ( AltCon )
  60 import PprCore          ( {- instances -} )
  61 import PrimOp           ( PrimOp )
  62 import Outputable
  63 import Util             ( count )
  64 import Type             ( Type )
  65 import TyCon            ( TyCon )
  66 import UniqSet          ( isEmptyUniqSet, uniqSetToList, UniqSet )
  67 import Unique           ( Unique )
  68 import Bitmap
  69 import StaticFlags      ( opt_SccProfilingOn )
  70 import Module           ( Module, pprModule )
  71 \end{code}
  72
  73 %************************************************************************
  74 %*                                                                      *
  75 \subsection{@GenStgBinding@}
  76 %*                                                                      *
  77 %************************************************************************
  78
  79 As usual, expressions are interesting; other things are boring.  Here
  80 are the boring things [except note the @GenStgRhs@], parameterised
  81 with respect to binder and occurrence information (just as in
  82 @CoreSyn@):
  83
  84 There is one SRT for each group of bindings.
  85
  86 \begin{code}
  87 data GenStgBinding bndr occ
  88   = StgNonRec   bndr (GenStgRhs bndr occ)
  89   | StgRec      [(bndr, GenStgRhs bndr occ)]
  90 \end{code}
  91
  92 %************************************************************************
  93 %*                                                                      *
  94 \subsection{@GenStgArg@}
  95 %*                                                                      *
  96 %************************************************************************
  97
  98 \begin{code}
  99 data GenStgArg occ
 100   = StgVarArg   occ
 101   | StgLitArg   Literal
 102   | StgTypeArg  Type            -- For when we want to preserve all type info
 103 \end{code}
 104
 105 \begin{code}
 106 isStgTypeArg (StgTypeArg _) = True
 107 isStgTypeArg other          = False
 108
 109 isDllArg :: PackageId -> StgArg -> Bool
 110         -- Does this argument refer to something in a different DLL?
 111 isDllArg this_pkg (StgTypeArg v)  = False
 112 isDllArg this_pkg (StgVarArg v)   = isDllName this_pkg (idName v)
 113 isDllArg this_pkg (StgLitArg lit) = False
 114
 115 isDllConApp :: PackageId -> DataCon -> [StgArg] -> Bool
 116         -- Does this constructor application refer to
 117         -- anything in a different DLL?
 118         -- If so, we can't allocate it statically
 119 isDllConApp this_pkg con args
 120    = isDllName this_pkg (dataConName con) || any (isDllArg this_pkg) args
 121
 122 stgArgType :: StgArg -> Type
 123         -- Very half baked becase we have lost the type arguments
 124 stgArgType (StgVarArg v)   = idType v
 125 stgArgType (StgLitArg lit) = literalType lit
 126 stgArgType (StgTypeArg lit) = panic "stgArgType called on stgTypeArg"
 127 \end{code}
 128
 129 %************************************************************************
 130 %*                                                                      *
 131 \subsection{STG expressions}
 132 %*                                                                      *
 133 %************************************************************************
 134
 135 The @GenStgExpr@ data type is parameterised on binder and occurrence
 136 info, as before.
 137
 138 %************************************************************************
 139 %*                                                                      *
 140 \subsubsection{@GenStgExpr@ application}
 141 %*                                                                      *
 142 %************************************************************************
 143
 144 An application is of a function to a list of atoms [not expressions].
 145 Operationally, we want to push the arguments on the stack and call the
 146 function.  (If the arguments were expressions, we would have to build
 147 their closures first.)
 148
 149 There is no constructor for a lone variable; it would appear as
 150 @StgApp var [] _@.
 151 \begin{code}
 152 type GenStgLiveVars occ = UniqSet occ
 153
 154 data GenStgExpr bndr occ
 155   = StgApp
 156         occ             -- function
 157         [GenStgArg occ] -- arguments; may be empty
 158 \end{code}
 159
 160 %************************************************************************
 161 %*                                                                      *
 162 \subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications}
 163 %*                                                                      *
 164 %************************************************************************
 165
 166 There are a specialised forms of application, for
 167 constructors, primitives, and literals.
 168 \begin{code}
 169   | StgLit      Literal
 170
 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 _) = count isId bndrs
 420   -- The arity never includes type parameters, so
 421   -- when keeping type arguments and binders in the Stg syntax
 422   -- (opt_RuntimeTypes) we have to fliter out the type binders.
 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 (StgRhsClosure _ _ _ upd srt _ _)
 432   = isUpdatable upd || nonEmptySRT srt
 433 rhsHasCafRefs (StgRhsCon _ _ args)
 434   = any stgArgHasCafRefs args
 435
 436 stgArgHasCafRefs (StgVarArg id) = mayHaveCafRefs (idCafInfo id)
 437 stgArgHasCafRefs _ = False
 438 \end{code}
 439
 440 Here's the @StgBinderInfo@ type, and its combining op:
 441 \begin{code}
 442 data StgBinderInfo
 443   = NoStgBinderInfo
 444   | SatCallsOnly        -- All occurrences are *saturated* *function* calls
 445                         -- This means we don't need to build an info table and
 446                         -- slow entry code for the thing
 447                         -- Thunks never get this value
 448
 449 noBinderInfo = NoStgBinderInfo
 450 stgUnsatOcc  = NoStgBinderInfo
 451 stgSatOcc    = SatCallsOnly
 452
 453 satCallsOnly :: StgBinderInfo -> Bool
 454 satCallsOnly SatCallsOnly    = True
 455 satCallsOnly NoStgBinderInfo = False
 456
 457 combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
 458 combineStgBinderInfo SatCallsOnly SatCallsOnly = SatCallsOnly
 459 combineStgBinderInfo info1 info2               = NoStgBinderInfo
 460
 461 --------------
 462 pp_binder_info NoStgBinderInfo = empty
 463 pp_binder_info SatCallsOnly    = ptext SLIT("sat-only")
 464 \end{code}
 465
 466 %************************************************************************
 467 %*                                                                      *
 468 \subsection[Stg-case-alternatives]{STG case alternatives}
 469 %*                                                                      *
 470 %************************************************************************
 471
 472 Very like in @CoreSyntax@ (except no type-world stuff).
 473
 474 The type constructor is guaranteed not to be abstract; that is, we can
 475 see its representation.  This is important because the code generator
 476 uses it to determine return conventions etc.  But it's not trivial
 477 where there's a moduule loop involved, because some versions of a type
 478 constructor might not have all the constructors visible.  So
 479 mkStgAlgAlts (in CoreToStg) ensures that it gets the TyCon from the
 480 constructors or literals (which are guaranteed to have the Real McCoy)
 481 rather than from the scrutinee type.
 482
 483 \begin{code}
 484 type GenStgAlt bndr occ
 485   = (AltCon,            -- alts: data constructor,
 486      [bndr],            -- constructor's parameters,
 487      [Bool],            -- "use mask", same length as
 488                         -- parameters; a True in a
 489                         -- param's position if it is
 490                         -- used in the ...
 491      GenStgExpr bndr occ)       -- ...right-hand side.
 492
 493 data AltType
 494   = PolyAlt             -- Polymorphic (a type variable)
 495   | UbxTupAlt TyCon     -- Unboxed tuple
 496   | AlgAlt    TyCon     -- Algebraic data type; the AltCons will be DataAlts
 497   | PrimAlt   TyCon     -- Primitive data type; the AltCons will be LitAlts
 498 \end{code}
 499
 500 %************************************************************************
 501 %*                                                                      *
 502 \subsection[Stg]{The Plain STG parameterisation}
 503 %*                                                                      *
 504 %************************************************************************
 505
 506 This happens to be the only one we use at the moment.
 507
 508 \begin{code}
 509 type StgBinding     = GenStgBinding     Id Id
 510 type StgArg         = GenStgArg         Id
 511 type StgLiveVars    = GenStgLiveVars    Id
 512 type StgExpr        = GenStgExpr        Id Id
 513 type StgRhs         = GenStgRhs         Id Id
 514 type StgAlt         = GenStgAlt         Id Id
 515 \end{code}
 516
 517 %************************************************************************
 518 %*                                                                      *
 519 \subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
 520 %*                                                                      *
 521 %************************************************************************
 522
 523 This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
 524
 525 A @ReEntrant@ closure may be entered multiple times, but should not be
 526 updated or blackholed.  An @Updatable@ closure should be updated after
 527 evaluation (and may be blackholed during evaluation).  A @SingleEntry@
 528 closure will only be entered once, and so need not be updated but may
 529 safely be blackholed.
 530
 531 \begin{code}
 532 data UpdateFlag = ReEntrant | Updatable | SingleEntry
 533
 534 instance Outputable UpdateFlag where
 535     ppr u
 536       = char (case u of { ReEntrant -> 'r';  Updatable -> 'u';  SingleEntry -> 's' })
 537
 538 isUpdatable ReEntrant   = False
 539 isUpdatable SingleEntry = False
 540 isUpdatable Updatable   = True
 541 \end{code}
 542
 543 %************************************************************************
 544 %*                                                                      *
 545 \subsubsection{StgOp}
 546 %*                                                                      *
 547 %************************************************************************
 548
 549 An StgOp allows us to group together PrimOps and ForeignCalls.
 550 It's quite useful to move these around together, notably
 551 in StgOpApp and COpStmt.
 552
 553 \begin{code}
 554 data StgOp = StgPrimOp  PrimOp
 555
 556            | StgFCallOp ForeignCall Unique
 557                 -- The Unique is occasionally needed by the C pretty-printer
 558                 -- (which lacks a unique supply), notably when generating a
 559                 -- typedef for foreign-export-dynamic
 560 \end{code}
 561
 562
 563 %************************************************************************
 564 %*                                                                      *
 565 \subsubsection[Static Reference Tables]{@SRT@}
 566 %*                                                                      *
 567 %************************************************************************
 568
 569 There is one SRT per top-level function group.  Each local binding and
 570 case expression within this binding group has a subrange of the whole
 571 SRT, expressed as an offset and length.
 572
 573 In CoreToStg we collect the list of CafRefs at each SRT site, which is later
 574 converted into the length and offset form by the SRT pass.
 575
 576 \begin{code}
 577 data SRT = NoSRT
 578          | SRTEntries IdSet
 579                 -- generated by CoreToStg
 580          | SRT !Int{-offset-} !Int{-length-} !Bitmap{-bitmap-}
 581                 -- generated by computeSRTs
 582
 583 noSRT :: SRT
 584 noSRT = NoSRT
 585
 586 nonEmptySRT NoSRT           = False
 587 nonEmptySRT (SRTEntries vs) = not (isEmptyVarSet vs)
 588 nonEmptySRT _               = True
 589
 590 pprSRT (NoSRT) = ptext SLIT("_no_srt_")
 591 pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids
 592 pprSRT (SRT off length bitmap) = parens (ppr off <> comma <> text "*bitmap*")
 593 \end{code}
 594
 595 %************************************************************************
 596 %*                                                                      *
 597 \subsection[Stg-pretty-printing]{Pretty-printing}
 598 %*                                                                      *
 599 %************************************************************************
 600
 601 Robin Popplestone asked for semi-colon separators on STG binds; here's
 602 hoping he likes terminators instead...  Ditto for case alternatives.
 603
 604 \begin{code}
 605 pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee)
 606                  => GenStgBinding bndr bdee -> SDoc
 607
 608 pprGenStgBinding (StgNonRec bndr rhs)
 609   = hang (hsep [ppr bndr, equals])
 610         4 ((<>) (ppr rhs) semi)
 611
 612 pprGenStgBinding (StgRec pairs)
 613   = vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) :
 614            (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))])
 615   where
 616     ppr_bind (bndr, expr)
 617       = hang (hsep [ppr bndr, equals])
 618              4 ((<>) (ppr expr) semi)
 619
 620 pprStgBinding  :: StgBinding -> SDoc
 621 pprStgBinding  bind  = pprGenStgBinding bind
 622
 623 pprStgBindings :: [StgBinding] -> SDoc
 624 pprStgBindings binds = vcat (map pprGenStgBinding binds)
 625
 626 pprGenStgBindingWithSRT
 627         :: (Outputable bndr, Outputable bdee, Ord bdee)
 628         => (GenStgBinding bndr bdee,[(Id,[Id])]) -> SDoc
 629
 630 pprGenStgBindingWithSRT (bind,srts)
 631   = vcat (pprGenStgBinding bind : map pprSRT srts)
 632   where pprSRT (id,srt) =
 633            ptext SLIT("SRT") <> parens (ppr id) <> ptext SLIT(": ") <> ppr srt
 634
 635 pprStgBindingsWithSRTs :: [(StgBinding,[(Id,[Id])])] -> SDoc
 636 pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds)
 637 \end{code}
 638
 639 \begin{code}
 640 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
 641     ppr = pprStgArg
 642
 643 instance (Outputable bndr, Outputable bdee, Ord bdee)
 644                 => Outputable (GenStgBinding bndr bdee) where
 645     ppr = pprGenStgBinding
 646
 647 instance (Outputable bndr, Outputable bdee, Ord bdee)
 648                 => Outputable (GenStgExpr bndr bdee) where
 649     ppr = pprStgExpr
 650
 651 instance (Outputable bndr, Outputable bdee, Ord bdee)
 652                 => Outputable (GenStgRhs bndr bdee) where
 653     ppr rhs = pprStgRhs rhs
 654 \end{code}
 655
 656 \begin{code}
 657 pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
 658
 659 pprStgArg (StgVarArg var) = ppr var
 660 pprStgArg (StgLitArg con) = ppr con
 661 pprStgArg (StgTypeArg ty) = char '@' <+> ppr ty
 662 \end{code}
 663
 664 \begin{code}
 665 pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee)
 666            => GenStgExpr bndr bdee -> SDoc
 667 -- special case
 668 pprStgExpr (StgLit lit)     = ppr lit
 669
 670 -- general case
 671 pprStgExpr (StgApp func args)
 672   = hang (ppr func)
 673          4 (sep (map (ppr) args))
 674 \end{code}
 675
 676 \begin{code}
 677 pprStgExpr (StgConApp con args)
 678   = hsep [ ppr con, brackets (interppSP args)]
 679
 680 pprStgExpr (StgOpApp op args _)
 681   = hsep [ pprStgOp op, brackets (interppSP args)]
 682
 683 pprStgExpr (StgLam _ bndrs body)
 684   =sep [ char '\\' <+> ppr bndrs <+> ptext SLIT("->"),
 685          pprStgExpr body ]
 686 \end{code}
 687
 688 \begin{code}
 689 -- special case: let v = <very specific thing>
 690 --               in
 691 --               let ...
 692 --               in
 693 --               ...
 694 --
 695 -- Very special!  Suspicious! (SLPJ)
 696
 697 {-
 698 pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
 699                         expr@(StgLet _ _))
 700   = ($$)
 701       (hang (hcat [ptext SLIT("let { "), ppr bndr, ptext SLIT(" = "),
 702                           ppr cc,
 703                           pp_binder_info bi,
 704                           ptext SLIT(" ["), ifPprDebug (interppSP free_vars), ptext SLIT("] \\"),
 705                           ppr upd_flag, ptext SLIT(" ["),
 706                           interppSP args, char ']'])
 707             8 (sep [hsep [ppr rhs, ptext SLIT("} in")]]))
 708       (ppr expr)
 709 -}
 710
 711 -- special case: let ... in let ...
 712
 713 pprStgExpr (StgLet bind expr@(StgLet _ _))
 714   = ($$)
 715       (sep [hang (ptext SLIT("let {"))
 716                 2 (hsep [pprGenStgBinding bind, ptext SLIT("} in")])])
 717       (ppr expr)
 718
 719 -- general case
 720 pprStgExpr (StgLet bind expr)
 721   = sep [hang (ptext SLIT("let {")) 2 (pprGenStgBinding bind),
 722            hang (ptext SLIT("} in ")) 2 (ppr expr)]
 723
 724 pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr)
 725   = sep [hang (ptext SLIT("let-no-escape {"))
 726                 2 (pprGenStgBinding bind),
 727            hang ((<>) (ptext SLIT("} in "))
 728                    (ifPprDebug (
 729                     nest 4 (
 730                       hcat [ptext  SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
 731                              ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
 732                              char ']']))))
 733                 2 (ppr expr)]
 734
 735 pprStgExpr (StgSCC cc expr)
 736   = sep [ hsep [ptext SLIT("_scc_"), ppr cc],
 737           pprStgExpr expr ]
 738
 739 pprStgExpr (StgTick m n expr)
 740   = sep [ hsep [ptext SLIT("_tick_"),  pprModule m,text (show n)],
 741           pprStgExpr expr ]
 742
 743 pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts)
 744   = sep [sep [ptext SLIT("case"),
 745            nest 4 (hsep [pprStgExpr expr,
 746              ifPprDebug (dcolon <+> ppr alt_type)]),
 747            ptext SLIT("of"), ppr bndr, char '{'],
 748            ifPprDebug (
 749            nest 4 (
 750              hcat [ptext  SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
 751                     ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
 752                     ptext SLIT("]; "),
 753                     pprMaybeSRT srt])),
 754            nest 2 (vcat (map pprStgAlt alts)),
 755            char '}']
 756
 757 pprStgAlt (con, params, use_mask, expr)
 758   = hang (hsep [ppr con, interppSP params, ptext SLIT("->")])
 759          4 (ppr expr <> semi)
 760
 761 pprStgOp (StgPrimOp  op)   = ppr op
 762 pprStgOp (StgFCallOp op _) = ppr op
 763
 764 instance Outputable AltType where
 765   ppr PolyAlt        = ptext SLIT("Polymorphic")
 766   ppr (UbxTupAlt tc) = ptext SLIT("UbxTup") <+> ppr tc
 767   ppr (AlgAlt tc)    = ptext SLIT("Alg")    <+> ppr tc
 768   ppr (PrimAlt tc)   = ptext SLIT("Prim")   <+> ppr tc
 769 \end{code}
 770
 771 \begin{code}
 772 pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
 773 pprStgLVs lvs
 774   = getPprStyle $ \ sty ->
 775     if userStyle sty || isEmptyUniqSet lvs then
 776         empty
 777     else
 778         hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
 779 \end{code}
 780
 781 \begin{code}
 782 pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee)
 783           => GenStgRhs bndr bdee -> SDoc
 784
 785 -- special case
 786 pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag srt [{-no args-}] (StgApp func []))
 787   = hcat [ ppr cc,
 788            pp_binder_info bi,
 789            brackets (ifPprDebug (ppr free_var)),
 790            ptext SLIT(" \\"), ppr upd_flag, pprMaybeSRT srt, ptext SLIT(" [] "), ppr func ]
 791
 792 -- general case
 793 pprStgRhs (StgRhsClosure cc bi free_vars upd_flag srt args body)
 794   = hang (hsep [if opt_SccProfilingOn then ppr cc else empty,
 795                 pp_binder_info bi,
 796                 ifPprDebug (brackets (interppSP free_vars)),
 797                 char '\\' <> ppr upd_flag, pprMaybeSRT srt, brackets (interppSP args)])
 798          4 (ppr body)
 799
 800 pprStgRhs (StgRhsCon cc con args)
 801   = hcat [ ppr cc,
 802            space, ppr con, ptext SLIT("! "), brackets (interppSP args)]
 803
 804 pprMaybeSRT (NoSRT) = empty
 805 pprMaybeSRT srt     = ptext SLIT("srt:") <> pprSRT srt
 806 \end{code}