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