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