ghc/compiler/stgSyn/StgSyn.lhs

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