ghc/compiler/stgSyn/StgSyn.lhs

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