ghc/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         GenStgCaseAlts(..), GenStgCaseDefault(..),
  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,
  28         StgCaseAlts, StgCaseDefault,
  29
  30         -- StgOp
  31         StgOp(..),
  32
  33         -- SRTs
  34         SRT(..), noSRT, nonEmptySRT,
  35
  36         -- utils
  37         stgBindHasCafRefs,  stgArgHasCafRefs, stgRhsArity, getArgPrimRep,
  38         isLitLitArg, isDllConApp, isStgTypeArg,
  39         stgArgType, stgBinders,
  40
  41         pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs, pprStgAlts
  42
  43 #ifdef DEBUG
  44         , pprStgLVs
  45 #endif
  46     ) where
  47
  48 #include "HsVersions.h"
  49
  50 import CostCentre       ( CostCentreStack, CostCentre )
  51 import VarSet           ( IdSet, isEmptyVarSet )
  52 import Var              ( isId )
  53 import Id               ( Id, idName, idPrimRep, idType, idCafInfo )
  54 import IdInfo           ( mayHaveCafRefs )
  55 import Name             ( isDllName )
  56 import Literal          ( Literal, literalType, isLitLitLit, literalPrimRep )
  57 import ForeignCall      ( ForeignCall )
  58 import DataCon          ( DataCon, dataConName )
  59 import PrimOp           ( PrimOp )
  60 import Outputable
  61 import Util             ( count )
  62 import Type             ( Type )
  63 import TyCon            ( TyCon )
  64 import UniqSet          ( isEmptyUniqSet, uniqSetToList, UniqSet )
  65 import Unique           ( Unique )
  66 import Bitmap
  67 import CmdLineOpts      ( opt_SccProfilingOn )
  68 \end{code}
  69
  70 %************************************************************************
  71 %*                                                                      *
  72 \subsection{@GenStgBinding@}
  73 %*                                                                      *
  74 %************************************************************************
  75
  76 As usual, expressions are interesting; other things are boring.  Here
  77 are the boring things [except note the @GenStgRhs@], parameterised
  78 with respect to binder and occurrence information (just as in
  79 @CoreSyn@):
  80
  81 There is one SRT for each group of bindings.
  82
  83 \begin{code}
  84 data GenStgBinding bndr occ
  85   = StgNonRec   bndr (GenStgRhs bndr occ)
  86   | StgRec      [(bndr, GenStgRhs bndr occ)]
  87
  88 stgBinders :: GenStgBinding bndr occ -> [bndr]
  89 stgBinders (StgNonRec b _) = [b]
  90 stgBinders (StgRec bs)     = map fst bs
  91 \end{code}
  92
  93 %************************************************************************
  94 %*                                                                      *
  95 \subsection{@GenStgArg@}
  96 %*                                                                      *
  97 %************************************************************************
  98
  99 \begin{code}
 100 data GenStgArg occ
 101   = StgVarArg   occ
 102   | StgLitArg   Literal
 103   | StgTypeArg  Type            -- For when we want to preserve all type info
 104 \end{code}
 105
 106 \begin{code}
 107 getArgPrimRep (StgVarArg local) = idPrimRep local
 108 getArgPrimRep (StgLitArg lit)   = literalPrimRep lit
 109
 110 isLitLitArg (StgLitArg lit) = isLitLitLit lit
 111 isLitLitArg _               = False
 112
 113 isStgTypeArg (StgTypeArg _) = True
 114 isStgTypeArg other          = False
 115
 116 isDllArg :: StgArg -> Bool
 117         -- Does this argument refer to something in a different DLL?
 118 isDllArg (StgTypeArg v)   = False
 119 isDllArg (StgVarArg v)   = isDllName (idName v)
 120 isDllArg (StgLitArg lit) = isLitLitLit lit
 121
 122 isDllConApp :: 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 con args = isDllName (dataConName con) || any isDllArg 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   DataCon
 178                 [GenStgArg occ] -- Saturated
 179
 180   | StgOpApp    StgOp           -- Primitive op or foreign call
 181                 [GenStgArg occ] -- Saturated
 182                 Type            -- Result type; we need to know the result type
 183                                 -- so that we can assign result registers.
 184 \end{code}
 185
 186 %************************************************************************
 187 %*                                                                      *
 188 \subsubsection{@StgLam@}
 189 %*                                                                      *
 190 %************************************************************************
 191
 192 StgLam is used *only* during CoreToStg's work.  Before CoreToStg has finished
 193 it encodes (\x -> e) as (let f = \x -> e in f)
 194
 195 \begin{code}
 196   | StgLam
 197         Type            -- Type of whole lambda (useful when making a binder for it)
 198         [bndr]
 199         StgExpr         -- Body of lambda
 200 \end{code}
 201
 202
 203 %************************************************************************
 204 %*                                                                      *
 205 \subsubsection{@GenStgExpr@: case-expressions}
 206 %*                                                                      *
 207 %************************************************************************
 208
 209 This has the same boxed/unboxed business as Core case expressions.
 210 \begin{code}
 211   | StgCase
 212         (GenStgExpr bndr occ)
 213                         -- the thing to examine
 214
 215         (GenStgLiveVars occ) -- Live vars of whole case expression,
 216                         -- plus everything that happens after the case
 217                         -- i.e., those which mustn't be overwritten
 218
 219         (GenStgLiveVars occ) -- Live vars of RHSs (plus what happens afterwards)
 220                         -- i.e., those which must be saved before eval.
 221                         --
 222                         -- note that an alt's constructor's
 223                         -- binder-variables are NOT counted in the
 224                         -- free vars for the alt's RHS
 225
 226         bndr            -- binds the result of evaluating the scrutinee
 227
 228         SRT             -- The SRT for the continuation
 229
 230         (GenStgCaseAlts bndr occ)
 231 \end{code}
 232
 233 %************************************************************************
 234 %*                                                                      *
 235 \subsubsection{@GenStgExpr@:  @let(rec)@-expressions}
 236 %*                                                                      *
 237 %************************************************************************
 238
 239 The various forms of let(rec)-expression encode most of the
 240 interesting things we want to do.
 241 \begin{enumerate}
 242 \item
 243 \begin{verbatim}
 244 let-closure x = [free-vars] expr [args]
 245 in e
 246 \end{verbatim}
 247 is equivalent to
 248 \begin{verbatim}
 249 let x = (\free-vars -> \args -> expr) free-vars
 250 \end{verbatim}
 251 \tr{args} may be empty (and is for most closures).  It isn't under
 252 circumstances like this:
 253 \begin{verbatim}
 254 let x = (\y -> y+z)
 255 \end{verbatim}
 256 This gets mangled to
 257 \begin{verbatim}
 258 let-closure x = [z] [y] (y+z)
 259 \end{verbatim}
 260 The idea is that we compile code for @(y+z)@ in an environment in which
 261 @z@ is bound to an offset from \tr{Node}, and @y@ is bound to an
 262 offset from the stack pointer.
 263
 264 (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)
 265
 266 \item
 267 \begin{verbatim}
 268 let-constructor x = Constructor [args]
 269 in e
 270 \end{verbatim}
 271
 272 (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)
 273
 274 \item
 275 Letrec-expressions are essentially the same deal as
 276 let-closure/let-constructor, so we use a common structure and
 277 distinguish between them with an @is_recursive@ boolean flag.
 278
 279 \item
 280 \begin{verbatim}
 281 let-unboxed u = an arbitrary arithmetic expression in unboxed values
 282 in e
 283 \end{verbatim}
 284 All the stuff on the RHS must be fully evaluated.  No function calls either!
 285
 286 (We've backed away from this toward case-expressions with
 287 suitably-magical alts ...)
 288
 289 \item
 290 ~[Advanced stuff here!  Not to start with, but makes pattern matching
 291 generate more efficient code.]
 292
 293 \begin{verbatim}
 294 let-escapes-not fail = expr
 295 in e'
 296 \end{verbatim}
 297 Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,
 298 or pass it to another function.  All @e'@ will ever do is tail-call @fail@.
 299 Rather than build a closure for @fail@, all we need do is to record the stack
 300 level at the moment of the @let-escapes-not@; then entering @fail@ is just
 301 a matter of adjusting the stack pointer back down to that point and entering
 302 the code for it.
 303
 304 Another example:
 305 \begin{verbatim}
 306 f x y = let z = huge-expression in
 307         if y==1 then z else
 308         if y==2 then z else
 309         1
 310 \end{verbatim}
 311
 312 (A let-escapes-not is an @StgLetNoEscape@.)
 313
 314 \item
 315 We may eventually want:
 316 \begin{verbatim}
 317 let-literal x = Literal
 318 in e
 319 \end{verbatim}
 320
 321 (ToDo: is this obsolete?)
 322 \end{enumerate}
 323
 324 And so the code for let(rec)-things:
 325 \begin{code}
 326   | StgLet
 327         (GenStgBinding bndr occ)        -- right hand sides (see below)
 328         (GenStgExpr bndr occ)           -- body
 329
 330   | StgLetNoEscape                      -- remember: ``advanced stuff''
 331         (GenStgLiveVars occ)            -- Live in the whole let-expression
 332                                         -- Mustn't overwrite these stack slots
 333                                         -- *Doesn't* include binders of the let(rec).
 334
 335         (GenStgLiveVars occ)            -- Live in the right hand sides (only)
 336                                         -- These are the ones which must be saved on
 337                                         -- the stack if they aren't there already
 338                                         -- *Does* include binders of the let(rec) if recursive.
 339
 340         (GenStgBinding bndr occ)        -- right hand sides (see below)
 341         (GenStgExpr bndr occ)           -- body
 342 \end{code}
 343
 344 %************************************************************************
 345 %*                                                                      *
 346 \subsubsection{@GenStgExpr@: @scc@ expressions}
 347 %*                                                                      *
 348 %************************************************************************
 349
 350 Finally for @scc@ expressions we introduce a new STG construct.
 351
 352 \begin{code}
 353   | StgSCC
 354         CostCentre              -- label of SCC expression
 355         (GenStgExpr bndr occ)   -- scc expression
 356   -- end of GenStgExpr
 357 \end{code}
 358
 359 %************************************************************************
 360 %*                                                                      *
 361 \subsection{STG right-hand sides}
 362 %*                                                                      *
 363 %************************************************************************
 364
 365 Here's the rest of the interesting stuff for @StgLet@s; the first
 366 flavour is for closures:
 367 \begin{code}
 368 data GenStgRhs bndr occ
 369   = StgRhsClosure
 370         CostCentreStack         -- CCS to be attached (default is CurrentCCS)
 371         StgBinderInfo           -- Info about how this binder is used (see below)
 372         [occ]                   -- non-global free vars; a list, rather than
 373                                 -- a set, because order is important
 374         !UpdateFlag             -- ReEntrant | Updatable | SingleEntry
 375         SRT                     -- The SRT reference
 376         [bndr]                  -- arguments; if empty, then not a function;
 377                                 -- as above, order is important.
 378         (GenStgExpr bndr occ)   -- body
 379 \end{code}
 380 An example may be in order.  Consider:
 381 \begin{verbatim}
 382 let t = \x -> \y -> ... x ... y ... p ... q in e
 383 \end{verbatim}
 384 Pulling out the free vars and stylising somewhat, we get the equivalent:
 385 \begin{verbatim}
 386 let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
 387 \end{verbatim}
 388 Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are
 389 offsets from @Node@ into the closure, and the code ptr for the closure
 390 will be exactly that in parentheses above.
 391
 392 The second flavour of right-hand-side is for constructors (simple but important):
 393 \begin{code}
 394   | StgRhsCon
 395         CostCentreStack         -- CCS to be attached (default is CurrentCCS).
 396                                 -- Top-level (static) ones will end up with
 397                                 -- DontCareCCS, because we don't count static
 398                                 -- data in heap profiles, and we don't set CCCS
 399                                 -- from static closure.
 400         DataCon                 -- constructor
 401         [GenStgArg occ] -- args
 402 \end{code}
 403
 404 \begin{code}
 405 stgRhsArity :: StgRhs -> Int
 406 stgRhsArity (StgRhsClosure _ _ _ _ _ bndrs _) = count isId bndrs
 407   -- The arity never includes type parameters, so
 408   -- when keeping type arguments and binders in the Stg syntax
 409   -- (opt_RuntimeTypes) we have to fliter out the type binders.
 410 stgRhsArity (StgRhsCon _ _ _) = 0
 411 \end{code}
 412
 413 \begin{code}
 414 stgBindHasCafRefs :: GenStgBinding bndr Id -> Bool
 415 stgBindHasCafRefs (StgNonRec _ rhs) = rhsHasCafRefs rhs
 416 stgBindHasCafRefs (StgRec binds)    = any rhsHasCafRefs (map snd binds)
 417
 418 rhsHasCafRefs (StgRhsClosure _ _ _ upd srt _ _)
 419   = isUpdatable upd || nonEmptySRT srt
 420 rhsHasCafRefs (StgRhsCon _ _ args)
 421   = any stgArgHasCafRefs args
 422
 423 stgArgHasCafRefs (StgVarArg id) = mayHaveCafRefs (idCafInfo id)
 424 stgArgHasCafRefs _ = False
 425 \end{code}
 426
 427 Here's the @StgBinderInfo@ type, and its combining op:
 428 \begin{code}
 429 data StgBinderInfo
 430   = NoStgBinderInfo
 431   | SatCallsOnly        -- All occurrences are *saturated* *function* calls
 432                         -- This means we don't need to build an info table and
 433                         -- slow entry code for the thing
 434                         -- Thunks never get this value
 435
 436 noBinderInfo = NoStgBinderInfo
 437 stgUnsatOcc  = NoStgBinderInfo
 438 stgSatOcc    = SatCallsOnly
 439
 440 satCallsOnly :: StgBinderInfo -> Bool
 441 satCallsOnly SatCallsOnly    = True
 442 satCallsOnly NoStgBinderInfo = False
 443
 444 combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
 445 combineStgBinderInfo SatCallsOnly SatCallsOnly = SatCallsOnly
 446 combineStgBinderInfo info1 info2               = NoStgBinderInfo
 447
 448 --------------
 449 pp_binder_info NoStgBinderInfo = empty
 450 pp_binder_info SatCallsOnly    = ptext SLIT("sat-only")
 451 \end{code}
 452
 453 %************************************************************************
 454 %*                                                                      *
 455 \subsection[Stg-case-alternatives]{STG case alternatives}
 456 %*                                                                      *
 457 %************************************************************************
 458
 459 Just like in @CoreSyntax@ (except no type-world stuff).
 460
 461 * Algebraic cases are done using
 462         StgAlgAlts (Just tc) alts deflt
 463
 464 * Polymorphic cases, or case of a function type, are done using
 465         StgAlgAlts Nothing [] (StgBindDefault e)
 466
 467 * Primitive cases are done using
 468         StgPrimAlts tc alts deflt
 469
 470 We thought of giving polymorphic cases their own constructor,
 471 but we get a bit more code sharing this way
 472
 473 The type constructor in StgAlgAlts/StgPrimAlts is guaranteed not
 474 to be abstract; that is, we can see its representation.  This is
 475 important because the code generator uses it to determine return
 476 conventions etc.  But it's not trivial where there's a moduule loop
 477 involved, because some versions of a type constructor might not have
 478 all the constructors visible.  So mkStgAlgAlts (in CoreToStg) ensures
 479 that it gets the TyCon from the constructors or literals (which are
 480 guaranteed to have the Real McCoy) rather than from the scrutinee type.
 481
 482 \begin{code}
 483 data GenStgCaseAlts bndr occ
 484   = StgAlgAlts  (Maybe TyCon)                   -- Just tc => scrutinee type is
 485                                                 --            an algebraic data type
 486                                                 -- Nothing => scrutinee type is a type
 487                                                 --            variable or function type
 488                 [(DataCon,                      -- alts: data constructor,
 489                   [bndr],                       -- constructor's parameters,
 490                   [Bool],                       -- "use mask", same length as
 491                                                 -- parameters; a True in a
 492                                                 -- param's position if it is
 493                                                 -- used in the ...
 494                   GenStgExpr bndr occ)] -- ...right-hand side.
 495                 (GenStgCaseDefault bndr occ)
 496
 497   | StgPrimAlts TyCon
 498                 [(Literal,                      -- alts: unboxed literal,
 499                   GenStgExpr bndr occ)] -- rhs.
 500                 (GenStgCaseDefault bndr occ)
 501
 502 data GenStgCaseDefault bndr occ
 503   = StgNoDefault                                -- small con family: all
 504                                                 -- constructor accounted for
 505   | StgBindDefault (GenStgExpr bndr occ)
 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 StgCaseAlts    = GenStgCaseAlts    Id Id
 523 type StgCaseDefault = GenStgCaseDefault 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 \end{code}
 744
 745 \begin{code}
 746 pprStgExpr (StgSCC cc expr)
 747   = sep [ hsep [ptext SLIT("_scc_"), ppr cc],
 748           pprStgExpr expr ]
 749 \end{code}
 750
 751 \begin{code}
 752 pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alts)
 753   = sep [sep [ptext SLIT("case"),
 754            nest 4 (hsep [pprStgExpr expr,
 755              ifPprDebug (dcolon <+> pp_ty alts)]),
 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 (pprStgAlts alts),
 764            char '}']
 765   where
 766     pp_ty (StgAlgAlts  maybe_tycon _ _) = ppr maybe_tycon
 767     pp_ty (StgPrimAlts tycon       _ _) = ppr tycon
 768
 769 pprStgAlts (StgAlgAlts _ alts deflt)
 770       = vcat [ vcat (map (ppr_bxd_alt) alts),
 771                pprStgDefault deflt ]
 772       where
 773         ppr_bxd_alt (con, params, use_mask, expr)
 774           = hang (hsep [ppr con, interppSP params, ptext SLIT("->")])
 775                    4 ((<>) (ppr expr) semi)
 776
 777 pprStgAlts (StgPrimAlts _ alts deflt)
 778       = vcat [ vcat (map (ppr_ubxd_alt) alts),
 779                pprStgDefault deflt ]
 780       where
 781         ppr_ubxd_alt (lit, expr)
 782           = hang (hsep [ppr lit, ptext SLIT("->")])
 783                  4 ((<>) (ppr expr) semi)
 784
 785 pprStgDefault StgNoDefault          = empty
 786 pprStgDefault (StgBindDefault expr) = hang (hsep [ptext SLIT("DEFAULT"), ptext SLIT("->")])
 787                                          4 (ppr expr)
 788
 789 pprStgOp (StgPrimOp  op)   = ppr op
 790 pprStgOp (StgFCallOp op _) = ppr op
 791 \end{code}
 792
 793 \begin{code}
 794 pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
 795 pprStgLVs lvs
 796   = getPprStyle $ \ sty ->
 797     if userStyle sty || isEmptyUniqSet lvs then
 798         empty
 799     else
 800         hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
 801 \end{code}
 802
 803 \begin{code}
 804 pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee)
 805           => GenStgRhs bndr bdee -> SDoc
 806
 807 -- special case
 808 pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag srt [{-no args-}] (StgApp func []))
 809   = hcat [ ppr cc,
 810            pp_binder_info bi,
 811            brackets (ifPprDebug (ppr free_var)),
 812            ptext SLIT(" \\"), ppr upd_flag, pprMaybeSRT srt, ptext SLIT(" [] "), ppr func ]
 813
 814 -- general case
 815 pprStgRhs (StgRhsClosure cc bi free_vars upd_flag srt args body)
 816   = hang (hsep [if opt_SccProfilingOn then ppr cc else empty,
 817                 pp_binder_info bi,
 818                 ifPprDebug (brackets (interppSP free_vars)),
 819                 char '\\' <> ppr upd_flag, pprMaybeSRT srt, brackets (interppSP args)])
 820          4 (ppr body)
 821
 822 pprStgRhs (StgRhsCon cc con args)
 823   = hcat [ ppr cc,
 824            space, ppr con, ptext SLIT("! "), brackets (interppSP args)]
 825
 826 pprMaybeSRT (NoSRT) = empty
 827 pprMaybeSRT srt     = ptext SLIT("srt:") <> pprSRT srt
 828 \end{code}