compiler/stgSyn/StgSyn.lhs

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