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