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