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         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         StgArg(..), StgLiveVars(..),
  30         StgBinding(..), StgExpr(..), StgRhs(..),
  31         StgCaseAlts(..), StgCaseDefault(..),
  32
  33         pprPlainStgBinding,
  34         getArgPrimRep,
  35         isLitLitArg,
  36         stgArity,
  37         collectExportedStgBinders
  38
  39         -- and to make the interface self-sufficient...
  40     ) where
  41
  42 import Ubiq{-uitous-}
  43
  44 import CostCentre       ( showCostCentre )
  45 import Id               ( idPrimRep, GenId{-instance NamedThing-} )
  46 import Literal          ( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} )
  47 import Name             ( isExported, isSymLexeme )
  48 import Outputable       ( ifPprDebug, interppSP, interpp'SP,
  49                           Outputable(..){-instance * Bool-}
  50                         )
  51 import PprStyle         ( PprStyle(..) )
  52 import PprType          ( GenType{-instance Outputable-} )
  53 import Pretty           -- all of it
  54 import PrimOp           ( PrimOp{-instance Outputable-} )
  55 import Unique           ( pprUnique )
  56 import UniqSet          ( isEmptyUniqSet, uniqSetToList, UniqSet(..) )
  57 import Util             ( panic )
  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   | StgCoerceBinding bndr occ
  76 \end{code}
  77
  78 %************************************************************************
  79 %*                                                                      *
  80 \subsection{@GenStgArg@}
  81 %*                                                                      *
  82 %************************************************************************
  83
  84 \begin{code}
  85 data GenStgArg occ
  86   = StgVarArg   occ
  87   | StgLitArg   Literal
  88 \end{code}
  89
  90 \begin{code}
  91 getArgPrimRep (StgVarArg  local) = idPrimRep local
  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 collectExportedStgBinders
 482         :: [StgBinding] -- input program
 483         -> [Id]                 -- exported top-level Ids
 484
 485 collectExportedStgBinders binds
 486   = ex [] binds
 487   where
 488     ex es [] = es
 489
 490     ex es ((StgNonRec b _) : binds)
 491       = if not (isExported b) then
 492             ex es binds
 493         else
 494             ex (b:es) binds
 495
 496     ex es ((StgRec []) : binds) = ex es binds
 497
 498     ex es ((StgRec ((b, rhs) : pairs)) : binds)
 499       = ex es (StgNonRec b rhs : (StgRec pairs : binds))
 500             -- OK, a total hack; laziness rules
 501 \end{code}
 502
 503 %************************************************************************
 504 %*                                                                      *
 505 \subsection[Stg-pretty-printing]{Pretty-printing}
 506 %*                                                                      *
 507 %************************************************************************
 508
 509 Robin Popplestone asked for semi-colon separators on STG binds; here's
 510 hoping he likes terminators instead...  Ditto for case alternatives.
 511
 512 \begin{code}
 513 pprStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) =>
 514                 PprStyle -> GenStgBinding bndr bdee -> Pretty
 515
 516 pprStgBinding sty (StgNonRec bndr rhs)
 517   = ppHang (ppCat [ppr sty bndr, ppEquals])
 518          4 (ppBeside (ppr sty rhs) ppSemi)
 519
 520 pprStgBinding sty (StgCoerceBinding bndr occ)
 521   = ppHang (ppCat [ppr sty bndr, ppEquals, ppStr "{-Coerce-}"])
 522          4 (ppBeside (ppr sty occ) ppSemi)
 523
 524 pprStgBinding sty (StgRec pairs)
 525   = ppAboves ((ifPprDebug sty (ppStr "{- StgRec -}")) :
 526               (map (ppr_bind sty) pairs))
 527   where
 528     ppr_bind sty (bndr, expr)
 529       = ppHang (ppCat [ppr sty bndr, ppEquals])
 530              4 (ppBeside (ppr sty expr) ppSemi)
 531
 532 pprPlainStgBinding :: PprStyle -> StgBinding -> Pretty
 533 pprPlainStgBinding sty b = pprStgBinding sty b
 534 \end{code}
 535
 536 \begin{code}
 537 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
 538     ppr = pprStgArg
 539
 540 instance (Outputable bndr, Outputable bdee, Ord bdee)
 541                 => Outputable (GenStgBinding bndr bdee) where
 542     ppr = pprStgBinding
 543
 544 instance (Outputable bndr, Outputable bdee, Ord bdee)
 545                 => Outputable (GenStgExpr bndr bdee) where
 546     ppr = pprStgExpr
 547
 548 instance (Outputable bndr, Outputable bdee, Ord bdee)
 549                 => Outputable (GenStgRhs bndr bdee) where
 550     ppr sty rhs = pprStgRhs sty rhs
 551 \end{code}
 552
 553 \begin{code}
 554 pprStgArg :: (Outputable bdee) => PprStyle -> GenStgArg bdee -> Pretty
 555
 556 pprStgArg sty (StgVarArg var) = ppr sty var
 557 pprStgArg sty (StgLitArg lit) = ppr sty lit
 558 \end{code}
 559
 560 \begin{code}
 561 pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) =>
 562                 PprStyle -> GenStgExpr bndr bdee -> Pretty
 563 -- special case
 564 pprStgExpr sty (StgApp func [] lvs)
 565   = ppBeside (ppr sty func) (pprStgLVs sty lvs)
 566
 567 -- general case
 568 pprStgExpr sty (StgApp func args lvs)
 569   = ppHang (ppBeside (ppr sty func) (pprStgLVs sty lvs))
 570          4 (ppSep (map (ppr sty) args))
 571 \end{code}
 572
 573 \begin{code}
 574 pprStgExpr sty (StgCon con args lvs)
 575   = ppBesides [ ppBeside (ppr sty con) (pprStgLVs sty lvs),
 576                 ppStr "! [", interppSP sty args, ppStr "]" ]
 577
 578 pprStgExpr sty (StgPrim op args lvs)
 579   = ppBesides [ ppr sty op, ppChar '#', pprStgLVs sty lvs,
 580                 ppStr " [", interppSP sty args, ppStr "]" ]
 581 \end{code}
 582
 583 \begin{code}
 584 -- special case: let v = <very specific thing>
 585 --               in
 586 --               let ...
 587 --               in
 588 --               ...
 589 --
 590 -- Very special!  Suspicious! (SLPJ)
 591
 592 pprStgExpr sty (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
 593                         expr@(StgLet _ _))
 594   = ppAbove
 595       (ppHang (ppBesides [ppStr "let { ", ppr sty bndr, ppStr " = ",
 596                           ppStr (showCostCentre sty True{-as string-} cc),
 597                           pp_binder_info sty bi,
 598                           ppStr " [", ifPprDebug sty (interppSP sty free_vars), ppStr "] \\",
 599                           ppr sty upd_flag, ppStr " [",
 600                           interppSP sty args, ppStr "]"])
 601             8 (ppSep [ppCat [ppr sty rhs, ppStr "} in"]]))
 602       (ppr sty expr)
 603
 604 -- special case: let ... in let ...
 605
 606 pprStgExpr sty (StgLet bind expr@(StgLet _ _))
 607   = ppAbove
 608       (ppSep [ppHang (ppStr "let {") 2 (ppCat [pprStgBinding sty bind, ppStr "} in"])])
 609       (ppr sty expr)
 610
 611 -- general case
 612 pprStgExpr sty (StgLet bind expr)
 613   = ppSep [ppHang (ppStr "let {") 2 (pprStgBinding sty bind),
 614            ppHang (ppStr "} in ") 2 (ppr sty expr)]
 615
 616 pprStgExpr sty (StgLetNoEscape lvs_whole lvs_rhss bind expr)
 617   = ppSep [ppHang (ppStr "let-no-escape {")
 618                 2 (pprStgBinding sty bind),
 619            ppHang (ppBeside (ppStr "} in ")
 620                    (ifPprDebug sty (
 621                     ppNest 4 (
 622                       ppBesides [ppStr  "-- lvs: [", interppSP sty (uniqSetToList lvs_whole),
 623                              ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss),
 624                              ppStr "]"]))))
 625                 2 (ppr sty expr)]
 626 \end{code}
 627
 628 \begin{code}
 629 pprStgExpr sty (StgSCC ty cc expr)
 630   = ppSep [ ppCat [ppStr "_scc_", ppStr (showCostCentre sty True{-as string-} cc)],
 631             pprStgExpr sty expr ]
 632 \end{code}
 633
 634 \begin{code}
 635 pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts)
 636   = ppSep [ppSep [ppStr "case",
 637            ppNest 4 (ppCat [pprStgExpr sty expr,
 638              ifPprDebug sty (ppBeside (ppStr "::") (pp_ty alts))]),
 639            ppStr "of {"],
 640            ifPprDebug sty (
 641            ppNest 4 (
 642              ppBesides [ppStr  "-- lvs: [", interppSP sty (uniqSetToList lvs_whole),
 643                     ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss),
 644                     ppStr "]; uniq: ", pprUnique uniq])),
 645            ppNest 2 (ppr_alts sty alts),
 646            ppStr "}"]
 647   where
 648     pp_ty (StgAlgAlts  ty _ _) = ppr sty ty
 649     pp_ty (StgPrimAlts ty _ _) = ppr sty ty
 650
 651     ppr_alts sty (StgAlgAlts ty alts deflt)
 652       = ppAboves [ ppAboves (map (ppr_bxd_alt sty) alts),
 653                    ppr_default sty deflt ]
 654       where
 655         ppr_bxd_alt sty (con, params, use_mask, expr)
 656           = ppHang (ppCat [ppr_con sty con, interppSP sty params, ppStr "->"])
 657                    4 (ppBeside (ppr sty expr) ppSemi)
 658           where
 659             ppr_con sty con
 660               = if isSymLexeme con
 661                 then ppBesides [ppLparen, ppr sty con, ppRparen]
 662                 else ppr sty con
 663
 664     ppr_alts sty (StgPrimAlts ty alts deflt)
 665       = ppAboves [ ppAboves (map (ppr_ubxd_alt sty) alts),
 666                    ppr_default sty deflt ]
 667       where
 668         ppr_ubxd_alt sty (lit, expr)
 669           = ppHang (ppCat [ppr sty lit, ppStr "->"])
 670                  4 (ppBeside (ppr sty expr) ppSemi)
 671
 672     ppr_default sty StgNoDefault = ppNil
 673     ppr_default sty (StgBindDefault bndr used expr)
 674       = ppHang (ppCat [pp_binder, ppStr "->"]) 4 (ppr sty expr)
 675       where
 676         pp_binder = if used then ppr sty bndr else ppChar '_'
 677 \end{code}
 678
 679 \begin{code}
 680 -- pprStgLVs :: PprStyle -> GenStgLiveVars occ -> Pretty
 681
 682 pprStgLVs PprForUser lvs = ppNil
 683
 684 pprStgLVs sty lvs
 685   = if isEmptyUniqSet lvs then
 686         ppNil
 687     else
 688         ppBesides [ppStr "{-lvs:", interpp'SP sty (uniqSetToList lvs), ppStr "-}"]
 689 \end{code}
 690
 691 \begin{code}
 692 pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) =>
 693                 PprStyle -> GenStgRhs bndr bdee -> Pretty
 694
 695 -- special case
 696 pprStgRhs sty (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [] lvs))
 697   = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
 698                 pp_binder_info sty bi,
 699                 ppStr " [", ifPprDebug sty (ppr sty free_var),
 700             ppStr "] \\", ppr sty upd_flag, ppStr " [] ", ppr sty func ]
 701 -- general case
 702 pprStgRhs sty (StgRhsClosure cc bi free_vars upd_flag args body)
 703   = ppHang (ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
 704                 pp_binder_info sty bi,
 705                 ppStr " [", ifPprDebug sty (interppSP sty free_vars),
 706                 ppStr "] \\", ppr sty upd_flag, ppStr " [", interppSP sty args, ppStr "]"])
 707          4 (ppr sty body)
 708
 709 pprStgRhs sty (StgRhsCon cc con args)
 710   = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
 711                 ppSP, ppr sty con, ppStr " [", interppSP sty args, ppStr "]" ]
 712
 713 --------------
 714 pp_binder_info PprForUser _ = ppNil
 715
 716 pp_binder_info sty NoStgBinderInfo = ppNil
 717
 718 -- cases so boring that we print nothing
 719 pp_binder_info sty (StgBinderInfo True b c d e) = ppNil
 720
 721 -- general case
 722 pp_binder_info sty (StgBinderInfo a b c d e)
 723   = ppBesides [ppChar '(', ppInterleave ppComma (map pp_bool [a,b,c,d,e]), ppChar ')']
 724   where
 725     pp_bool x = ppr (panic "pp_bool") x
 726 \end{code}
 727
 728 Collect @IdInfo@ stuff that is most easily just snaffled straight
 729 from the STG bindings.
 730
 731 \begin{code}
 732 stgArity :: StgRhs -> Int
 733
 734 stgArity (StgRhsCon _ _ _)               = 0 -- it's a constructor, fully applied
 735 stgArity (StgRhsClosure _ _ _ _ args _ ) = length args
 736 \end{code}