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