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