ghc/compiler/stgSyn/StgSyn.lhs

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