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