compiler/stgSyn/StgSyn.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   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         GenStgAlt, AltType(..),
  18
  19         UpdateFlag(..), isUpdatable,
  20
  21         StgBinderInfo,
  22         noBinderInfo, stgSatOcc, stgUnsatOcc, satCallsOnly,
  23         combineStgBinderInfo,
  24
  25         -- a set of synonyms for the most common (only :-) parameterisation
  26         StgArg, StgLiveVars,
  27         StgBinding, StgExpr, StgRhs, StgAlt,
  28
  29         -- StgOp
  30         StgOp(..),
  31
  32         -- SRTs
  33         SRT(..),
  34
  35         -- utils
  36         stgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity,
  37         isDllConApp, isStgTypeArg,
  38         stgArgType,
  39
  40         pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs
  41
  42 #ifdef DEBUG
  43         , pprStgLVs
  44 #endif
  45     ) where
  46
  47 #include "HsVersions.h"
  48
  49 import CostCentre       ( CostCentreStack, CostCentre )
  50 import VarSet           ( IdSet, isEmptyVarSet )
  51 import Var              ( isId )
  52 import Id               ( Id, idName, idType, idCafInfo )
  53 import IdInfo           ( mayHaveCafRefs )
  54 import Packages         ( isDllName )
  55 import Literal          ( Literal, literalType )
  56 import ForeignCall      ( ForeignCall )
  57 import DataCon          ( DataCon, dataConName )
  58 import CoreSyn          ( AltCon )
  59 import PprCore          ( {- instances -} )
  60 import PrimOp           ( PrimOp )
  61 import Outputable
  62 import Util             ( count )
  63 import Type             ( Type )
  64 import TyCon            ( TyCon )
  65 import UniqSet
  66 import Unique           ( Unique )
  67 import Bitmap
  68 import StaticFlags      ( opt_SccProfilingOn )
  69 import Module
  70 \end{code}
  71
  72 %************************************************************************
  73 %*                                                                      *
  74 \subsection{@GenStgBinding@}
  75 %*                                                                      *
  76 %************************************************************************
  77
  78 As usual, expressions are interesting; other things are boring.  Here
  79 are the boring things [except note the @GenStgRhs@], parameterised
  80 with respect to binder and occurrence information (just as in
  81 @CoreSyn@):
  82
  83 There is one SRT for each group of bindings.
  84
  85 \begin{code}
  86 data GenStgBinding bndr occ
  87   = StgNonRec   bndr (GenStgRhs bndr occ)
  88   | StgRec      [(bndr, GenStgRhs bndr occ)]
  89 \end{code}
  90
  91 %************************************************************************
  92 %*                                                                      *
  93 \subsection{@GenStgArg@}
  94 %*                                                                      *
  95 %************************************************************************
  96
  97 \begin{code}
  98 data GenStgArg occ
  99   = StgVarArg   occ
 100   | StgLitArg   Literal
 101   | StgTypeArg  Type            -- For when we want to preserve all type info
 102 \end{code}
 103
 104 \begin{code}
 105 isStgTypeArg :: StgArg -> Bool
 106 isStgTypeArg (StgTypeArg _) = True
 107 isStgTypeArg _              = False
 108
 109 isDllArg :: PackageId -> StgArg -> Bool
 110         -- Does this argument refer to something in a different DLL?
 111 isDllArg this_pkg (StgVarArg v)  = isDllName this_pkg (idName v)
 112 isDllArg _        _              = False
 113
 114 isDllConApp :: PackageId -> DataCon -> [StgArg] -> Bool
 115         -- Does this constructor application refer to
 116         -- anything in a different DLL?
 117         -- If so, we can't allocate it statically
 118 isDllConApp this_pkg con args
 119    = isDllName this_pkg (dataConName con) || any (isDllArg this_pkg) args
 120
 121 stgArgType :: StgArg -> Type
 122         -- Very half baked becase we have lost the type arguments
 123 stgArgType (StgVarArg v)   = idType v
 124 stgArgType (StgLitArg lit) = literalType lit
 125 stgArgType (StgTypeArg _)  = panic "stgArgType called on stgTypeArg"
 126 \end{code}
 127
 128 %************************************************************************
 129 %*                                                                      *
 130 \subsection{STG expressions}
 131 %*                                                                      *
 132 %************************************************************************
 133
 134 The @GenStgExpr@ data type is parameterised on binder and occurrence
 135 info, as before.
 136
 137 %************************************************************************
 138 %*                                                                      *
 139 \subsubsection{@GenStgExpr@ application}
 140 %*                                                                      *
 141 %************************************************************************
 142
 143 An application is of a function to a list of atoms [not expressions].
 144 Operationally, we want to push the arguments on the stack and call the
 145 function.  (If the arguments were expressions, we would have to build
 146 their closures first.)
 147
 148 There is no constructor for a lone variable; it would appear as
 149 @StgApp var [] _@.
 150 \begin{code}
 151 type GenStgLiveVars occ = UniqSet occ
 152
 153 data GenStgExpr bndr occ
 154   = StgApp
 155         occ             -- function
 156         [GenStgArg occ] -- arguments; may be empty
 157 \end{code}
 158
 159 %************************************************************************
 160 %*                                                                      *
 161 \subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications}
 162 %*                                                                      *
 163 %************************************************************************
 164
 165 There are a specialised forms of application, for
 166 constructors, primitives, and literals.
 167 \begin{code}
 168   | StgLit      Literal
 169
 170         -- StgConApp is vital for returning unboxed tuples
 171         -- which can't be let-bound first
 172   | StgConApp   DataCon
 173                 [GenStgArg occ] -- Saturated
 174
 175   | StgOpApp    StgOp           -- Primitive op or foreign call
 176                 [GenStgArg occ] -- Saturated
 177                 Type            -- Result type
 178                                 -- We need to know this so that we can
 179                                 -- assign result registers
 180 \end{code}
 181
 182 %************************************************************************
 183 %*                                                                      *
 184 \subsubsection{@StgLam@}
 185 %*                                                                      *
 186 %************************************************************************
 187
 188 StgLam is used *only* during CoreToStg's work.  Before CoreToStg has finished
 189 it encodes (\x -> e) as (let f = \x -> e in f)
 190
 191 \begin{code}
 192   | StgLam
 193         Type            -- Type of whole lambda (useful when making a binder for it)
 194         [bndr]
 195         StgExpr         -- Body of lambda
 196 \end{code}
 197
 198
 199 %************************************************************************
 200 %*                                                                      *
 201 \subsubsection{@GenStgExpr@: case-expressions}
 202 %*                                                                      *
 203 %************************************************************************
 204
 205 This has the same boxed/unboxed business as Core case expressions.
 206 \begin{code}
 207   | StgCase
 208         (GenStgExpr bndr occ)
 209                         -- the thing to examine
 210
 211         (GenStgLiveVars occ) -- Live vars of whole case expression,
 212                         -- plus everything that happens after the case
 213                         -- i.e., those which mustn't be overwritten
 214
 215         (GenStgLiveVars occ) -- Live vars of RHSs (plus what happens afterwards)
 216                         -- i.e., those which must be saved before eval.
 217                         --
 218                         -- note that an alt's constructor's
 219                         -- binder-variables are NOT counted in the
 220                         -- free vars for the alt's RHS
 221
 222         bndr            -- binds the result of evaluating the scrutinee
 223
 224         SRT             -- The SRT for the continuation
 225
 226         AltType
 227
 228         [GenStgAlt bndr occ]    -- The DEFAULT case is always *first*
 229                                 -- if it is there at all
 230 \end{code}
 231
 232 %************************************************************************
 233 %*                                                                      *
 234 \subsubsection{@GenStgExpr@:  @let(rec)@-expressions}
 235 %*                                                                      *
 236 %************************************************************************
 237
 238 The various forms of let(rec)-expression encode most of the
 239 interesting things we want to do.
 240 \begin{enumerate}
 241 \item
 242 \begin{verbatim}
 243 let-closure x = [free-vars] expr [args]
 244 in e
 245 \end{verbatim}
 246 is equivalent to
 247 \begin{verbatim}
 248 let x = (\free-vars -> \args -> expr) free-vars
 249 \end{verbatim}
 250 \tr{args} may be empty (and is for most closures).  It isn't under
 251 circumstances like this:
 252 \begin{verbatim}
 253 let x = (\y -> y+z)
 254 \end{verbatim}
 255 This gets mangled to
 256 \begin{verbatim}
 257 let-closure x = [z] [y] (y+z)
 258 \end{verbatim}
 259 The idea is that we compile code for @(y+z)@ in an environment in which
 260 @z@ is bound to an offset from \tr{Node}, and @y@ is bound to an
 261 offset from the stack pointer.
 262
 263 (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)
 264
 265 \item
 266 \begin{verbatim}
 267 let-constructor x = Constructor [args]
 268 in e
 269 \end{verbatim}
 270
 271 (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)
 272
 273 \item
 274 Letrec-expressions are essentially the same deal as
 275 let-closure/let-constructor, so we use a common structure and
 276 distinguish between them with an @is_recursive@ boolean flag.
 277
 278 \item
 279 \begin{verbatim}
 280 let-unboxed u = an arbitrary arithmetic expression in unboxed values
 281 in e
 282 \end{verbatim}
 283 All the stuff on the RHS must be fully evaluated.  No function calls either!
 284
 285 (We've backed away from this toward case-expressions with
 286 suitably-magical alts ...)
 287
 288 \item
 289 ~[Advanced stuff here!  Not to start with, but makes pattern matching
 290 generate more efficient code.]
 291
 292 \begin{verbatim}
 293 let-escapes-not fail = expr
 294 in e'
 295 \end{verbatim}
 296 Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,
 297 or pass it to another function.  All @e'@ will ever do is tail-call @fail@.
 298 Rather than build a closure for @fail@, all we need do is to record the stack
 299 level at the moment of the @let-escapes-not@; then entering @fail@ is just
 300 a matter of adjusting the stack pointer back down to that point and entering
 301 the code for it.
 302
 303 Another example:
 304 \begin{verbatim}
 305 f x y = let z = huge-expression in
 306         if y==1 then z else
 307         if y==2 then z else
 308         1
 309 \end{verbatim}
 310
 311 (A let-escapes-not is an @StgLetNoEscape@.)
 312
 313 \item
 314 We may eventually want:
 315 \begin{verbatim}
 316 let-literal x = Literal
 317 in e
 318 \end{verbatim}
 319
 320 (ToDo: is this obsolete?)
 321 \end{enumerate}
 322
 323 And so the code for let(rec)-things:
 324 \begin{code}
 325   | StgLet
 326         (GenStgBinding bndr occ)        -- right hand sides (see below)
 327         (GenStgExpr bndr occ)           -- body
 328
 329   | StgLetNoEscape                      -- remember: ``advanced stuff''
 330         (GenStgLiveVars occ)            -- Live in the whole let-expression
 331                                         -- Mustn't overwrite these stack slots
 332                                         --  *Doesn't* include binders of the let(rec).
 333
 334         (GenStgLiveVars occ)            -- Live in the right hand sides (only)
 335                                         -- These are the ones which must be saved on
 336                                         -- the stack if they aren't there already
 337                                         --  *Does* include binders of the let(rec) if recursive.
 338
 339         (GenStgBinding bndr occ)        -- right hand sides (see below)
 340         (GenStgExpr bndr occ)           -- body
 341 \end{code}
 342
 343 %************************************************************************
 344 %*                                                                      *
 345 \subsubsection{@GenStgExpr@: @scc@ expressions}
 346 %*                                                                      *
 347 %************************************************************************
 348
 349 Finally for @scc@ expressions we introduce a new STG construct.
 350
 351 \begin{code}
 352   | StgSCC
 353         CostCentre              -- label of SCC expression
 354         (GenStgExpr bndr occ)   -- scc expression
 355 \end{code}
 356
 357 %************************************************************************
 358 %*                                                                      *
 359 \subsubsection{@GenStgExpr@: @hpc@ expressions}
 360 %*                                                                      *
 361 %************************************************************************
 362
 363 Finally for @scc@ expressions we introduce a new STG construct.
 364
 365 \begin{code}
 366   | StgTick
 367     Module                      -- the module of the source of this tick
 368     Int                         -- tick number
 369     (GenStgExpr bndr occ)       -- sub expression
 370   -- end of GenStgExpr
 371 \end{code}
 372
 373 %************************************************************************
 374 %*                                                                      *
 375 \subsection{STG right-hand sides}
 376 %*                                                                      *
 377 %************************************************************************
 378
 379 Here's the rest of the interesting stuff for @StgLet@s; the first
 380 flavour is for closures:
 381 \begin{code}
 382 data GenStgRhs bndr occ
 383   = StgRhsClosure
 384         CostCentreStack         -- CCS to be attached (default is CurrentCCS)
 385         StgBinderInfo           -- Info about how this binder is used (see below)
 386         [occ]                   -- non-global free vars; a list, rather than
 387                                 -- a set, because order is important
 388         !UpdateFlag             -- ReEntrant | Updatable | SingleEntry
 389         SRT                     -- The SRT reference
 390         [bndr]                  -- arguments; if empty, then not a function;
 391                                 -- as above, order is important.
 392         (GenStgExpr bndr occ)   -- body
 393 \end{code}
 394 An example may be in order.  Consider:
 395 \begin{verbatim}
 396 let t = \x -> \y -> ... x ... y ... p ... q in e
 397 \end{verbatim}
 398 Pulling out the free vars and stylising somewhat, we get the equivalent:
 399 \begin{verbatim}
 400 let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
 401 \end{verbatim}
 402 Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are
 403 offsets from @Node@ into the closure, and the code ptr for the closure
 404 will be exactly that in parentheses above.
 405
 406 The second flavour of right-hand-side is for constructors (simple but important):
 407 \begin{code}
 408   | StgRhsCon
 409         CostCentreStack         -- CCS to be attached (default is CurrentCCS).
 410                                 -- Top-level (static) ones will end up with
 411                                 -- DontCareCCS, because we don't count static
 412                                 -- data in heap profiles, and we don't set CCCS
 413                                 -- from static closure.
 414         DataCon                 -- constructor
 415         [GenStgArg occ] -- args
 416 \end{code}
 417
 418 \begin{code}
 419 stgRhsArity :: StgRhs -> Int
 420 stgRhsArity (StgRhsClosure _ _ _ _ _ bndrs _) = count isId bndrs
 421   -- The arity never includes type parameters, so
 422   -- when keeping type arguments and binders in the Stg syntax
 423   -- (opt_RuntimeTypes) we have to fliter out the type binders.
 424 stgRhsArity (StgRhsCon _ _ _) = 0
 425 \end{code}
 426
 427 \begin{code}
 428 stgBindHasCafRefs :: GenStgBinding bndr Id -> Bool
 429 stgBindHasCafRefs (StgNonRec _ rhs) = rhsHasCafRefs rhs
 430 stgBindHasCafRefs (StgRec binds)    = any rhsHasCafRefs (map snd binds)
 431
 432 rhsHasCafRefs :: GenStgRhs bndr Id -> Bool
 433 rhsHasCafRefs (StgRhsClosure _ _ _ upd srt _ _)
 434   = isUpdatable upd || nonEmptySRT srt
 435 rhsHasCafRefs (StgRhsCon _ _ args)
 436   = any stgArgHasCafRefs args
 437
 438 stgArgHasCafRefs :: GenStgArg Id -> Bool
 439 stgArgHasCafRefs (StgVarArg id) = mayHaveCafRefs (idCafInfo id)
 440 stgArgHasCafRefs _ = False
 441 \end{code}
 442
 443 Here's the @StgBinderInfo@ type, and its combining op:
 444 \begin{code}
 445 data StgBinderInfo
 446   = NoStgBinderInfo
 447   | SatCallsOnly        -- All occurrences are *saturated* *function* calls
 448                         -- This means we don't need to build an info table and
 449                         -- slow entry code for the thing
 450                         -- Thunks never get this value
 451
 452 noBinderInfo, stgUnsatOcc, stgSatOcc :: StgBinderInfo
 453 noBinderInfo = NoStgBinderInfo
 454 stgUnsatOcc  = NoStgBinderInfo
 455 stgSatOcc    = SatCallsOnly
 456
 457 satCallsOnly :: StgBinderInfo -> Bool
 458 satCallsOnly SatCallsOnly    = True
 459 satCallsOnly NoStgBinderInfo = False
 460
 461 combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
 462 combineStgBinderInfo SatCallsOnly SatCallsOnly = SatCallsOnly
 463 combineStgBinderInfo _            _            = NoStgBinderInfo
 464
 465 --------------
 466 pp_binder_info :: StgBinderInfo -> SDoc
 467 pp_binder_info NoStgBinderInfo = empty
 468 pp_binder_info SatCallsOnly    = ptext SLIT("sat-only")
 469 \end{code}
 470
 471 %************************************************************************
 472 %*                                                                      *
 473 \subsection[Stg-case-alternatives]{STG case alternatives}
 474 %*                                                                      *
 475 %************************************************************************
 476
 477 Very like in @CoreSyntax@ (except no type-world stuff).
 478
 479 The type constructor is guaranteed not to be abstract; that is, we can
 480 see its representation.  This is important because the code generator
 481 uses it to determine return conventions etc.  But it's not trivial
 482 where there's a moduule loop involved, because some versions of a type
 483 constructor might not have all the constructors visible.  So
 484 mkStgAlgAlts (in CoreToStg) ensures that it gets the TyCon from the
 485 constructors or literals (which are guaranteed to have the Real McCoy)
 486 rather than from the scrutinee type.
 487
 488 \begin{code}
 489 type GenStgAlt bndr occ
 490   = (AltCon,            -- alts: data constructor,
 491      [bndr],            -- constructor's parameters,
 492      [Bool],            -- "use mask", same length as
 493                         -- parameters; a True in a
 494                         -- param's position if it is
 495                         -- used in the ...
 496      GenStgExpr bndr occ)       -- ...right-hand side.
 497
 498 data AltType
 499   = PolyAlt             -- Polymorphic (a type variable)
 500   | UbxTupAlt TyCon     -- Unboxed tuple
 501   | AlgAlt    TyCon     -- Algebraic data type; the AltCons will be DataAlts
 502   | PrimAlt   TyCon     -- Primitive data type; the AltCons will be LitAlts
 503 \end{code}
 504
 505 %************************************************************************
 506 %*                                                                      *
 507 \subsection[Stg]{The Plain STG parameterisation}
 508 %*                                                                      *
 509 %************************************************************************
 510
 511 This happens to be the only one we use at the moment.
 512
 513 \begin{code}
 514 type StgBinding     = GenStgBinding     Id Id
 515 type StgArg         = GenStgArg         Id
 516 type StgLiveVars    = GenStgLiveVars    Id
 517 type StgExpr        = GenStgExpr        Id Id
 518 type StgRhs         = GenStgRhs         Id Id
 519 type StgAlt         = GenStgAlt         Id Id
 520 \end{code}
 521
 522 %************************************************************************
 523 %*                                                                      *
 524 \subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
 525 %*                                                                      *
 526 %************************************************************************
 527
 528 This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
 529
 530 A @ReEntrant@ closure may be entered multiple times, but should not be
 531 updated or blackholed.  An @Updatable@ closure should be updated after
 532 evaluation (and may be blackholed during evaluation).  A @SingleEntry@
 533 closure will only be entered once, and so need not be updated but may
 534 safely be blackholed.
 535
 536 \begin{code}
 537 data UpdateFlag = ReEntrant | Updatable | SingleEntry
 538
 539 instance Outputable UpdateFlag where
 540     ppr u
 541       = char (case u of { ReEntrant -> 'r';  Updatable -> 'u';  SingleEntry -> 's' })
 542
 543 isUpdatable :: UpdateFlag -> Bool
 544 isUpdatable ReEntrant   = False
 545 isUpdatable SingleEntry = False
 546 isUpdatable Updatable   = True
 547 \end{code}
 548
 549 %************************************************************************
 550 %*                                                                      *
 551 \subsubsection{StgOp}
 552 %*                                                                      *
 553 %************************************************************************
 554
 555 An StgOp allows us to group together PrimOps and ForeignCalls.
 556 It's quite useful to move these around together, notably
 557 in StgOpApp and COpStmt.
 558
 559 \begin{code}
 560 data StgOp = StgPrimOp  PrimOp
 561
 562            | StgFCallOp ForeignCall Unique
 563                 -- The Unique is occasionally needed by the C pretty-printer
 564                 -- (which lacks a unique supply), notably when generating a
 565                 -- typedef for foreign-export-dynamic
 566 \end{code}
 567
 568
 569 %************************************************************************
 570 %*                                                                      *
 571 \subsubsection[Static Reference Tables]{@SRT@}
 572 %*                                                                      *
 573 %************************************************************************
 574
 575 There is one SRT per top-level function group.  Each local binding and
 576 case expression within this binding group has a subrange of the whole
 577 SRT, expressed as an offset and length.
 578
 579 In CoreToStg we collect the list of CafRefs at each SRT site, which is later
 580 converted into the length and offset form by the SRT pass.
 581
 582 \begin{code}
 583 data SRT = NoSRT
 584          | SRTEntries IdSet
 585                 -- generated by CoreToStg
 586          | SRT !Int{-offset-} !Int{-length-} !Bitmap{-bitmap-}
 587                 -- generated by computeSRTs
 588
 589 nonEmptySRT :: SRT -> Bool
 590 nonEmptySRT NoSRT           = False
 591 nonEmptySRT (SRTEntries vs) = not (isEmptyVarSet vs)
 592 nonEmptySRT _               = True
 593
 594 pprSRT :: SRT -> SDoc
 595 pprSRT (NoSRT)          = ptext SLIT("_no_srt_")
 596 pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids
 597 pprSRT (SRT off _ _)    = parens (ppr off <> comma <> text "*bitmap*")
 598 \end{code}
 599
 600 %************************************************************************
 601 %*                                                                      *
 602 \subsection[Stg-pretty-printing]{Pretty-printing}
 603 %*                                                                      *
 604 %************************************************************************
 605
 606 Robin Popplestone asked for semi-colon separators on STG binds; here's
 607 hoping he likes terminators instead...  Ditto for case alternatives.
 608
 609 \begin{code}
 610 pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee)
 611                  => GenStgBinding bndr bdee -> SDoc
 612
 613 pprGenStgBinding (StgNonRec bndr rhs)
 614   = hang (hsep [ppr bndr, equals])
 615         4 ((<>) (ppr rhs) semi)
 616
 617 pprGenStgBinding (StgRec pairs)
 618   = vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) :
 619            (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))])
 620   where
 621     ppr_bind (bndr, expr)
 622       = hang (hsep [ppr bndr, equals])
 623              4 ((<>) (ppr expr) semi)
 624
 625 pprStgBinding  :: StgBinding -> SDoc
 626 pprStgBinding  bind  = pprGenStgBinding bind
 627
 628 pprStgBindings :: [StgBinding] -> SDoc
 629 pprStgBindings binds = vcat (map pprGenStgBinding binds)
 630
 631 pprGenStgBindingWithSRT
 632         :: (Outputable bndr, Outputable bdee, Ord bdee)
 633         => (GenStgBinding bndr bdee,[(Id,[Id])]) -> SDoc
 634
 635 pprGenStgBindingWithSRT (bind,srts)
 636   = vcat (pprGenStgBinding bind : map pprSRT srts)
 637   where pprSRT (id,srt) =
 638            ptext SLIT("SRT") <> parens (ppr id) <> ptext SLIT(": ") <> ppr srt
 639
 640 pprStgBindingsWithSRTs :: [(StgBinding,[(Id,[Id])])] -> SDoc
 641 pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds)
 642 \end{code}
 643
 644 \begin{code}
 645 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
 646     ppr = pprStgArg
 647
 648 instance (Outputable bndr, Outputable bdee, Ord bdee)
 649                 => Outputable (GenStgBinding bndr bdee) where
 650     ppr = pprGenStgBinding
 651
 652 instance (Outputable bndr, Outputable bdee, Ord bdee)
 653                 => Outputable (GenStgExpr bndr bdee) where
 654     ppr = pprStgExpr
 655
 656 instance (Outputable bndr, Outputable bdee, Ord bdee)
 657                 => Outputable (GenStgRhs bndr bdee) where
 658     ppr rhs = pprStgRhs rhs
 659 \end{code}
 660
 661 \begin{code}
 662 pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
 663
 664 pprStgArg (StgVarArg var) = ppr var
 665 pprStgArg (StgLitArg con) = ppr con
 666 pprStgArg (StgTypeArg ty) = char '@' <+> ppr ty
 667 \end{code}
 668
 669 \begin{code}
 670 pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee)
 671            => GenStgExpr bndr bdee -> SDoc
 672 -- special case
 673 pprStgExpr (StgLit lit)     = ppr lit
 674
 675 -- general case
 676 pprStgExpr (StgApp func args)
 677   = hang (ppr func)
 678          4 (sep (map (ppr) args))
 679 \end{code}
 680
 681 \begin{code}
 682 pprStgExpr (StgConApp con args)
 683   = hsep [ ppr con, brackets (interppSP args)]
 684
 685 pprStgExpr (StgOpApp op args _)
 686   = hsep [ pprStgOp op, brackets (interppSP args)]
 687
 688 pprStgExpr (StgLam _ bndrs body)
 689   =sep [ char '\\' <+> ppr bndrs <+> ptext SLIT("->"),
 690          pprStgExpr body ]
 691 \end{code}
 692
 693 \begin{code}
 694 -- special case: let v = <very specific thing>
 695 --               in
 696 --               let ...
 697 --               in
 698 --               ...
 699 --
 700 -- Very special!  Suspicious! (SLPJ)
 701
 702 {-
 703 pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
 704                         expr@(StgLet _ _))
 705   = ($$)
 706       (hang (hcat [ptext SLIT("let { "), ppr bndr, ptext SLIT(" = "),
 707                           ppr cc,
 708                           pp_binder_info bi,
 709                           ptext SLIT(" ["), ifPprDebug (interppSP free_vars), ptext SLIT("] \\"),
 710                           ppr upd_flag, ptext SLIT(" ["),
 711                           interppSP args, char ']'])
 712             8 (sep [hsep [ppr rhs, ptext SLIT("} in")]]))
 713       (ppr expr)
 714 -}
 715
 716 -- special case: let ... in let ...
 717
 718 pprStgExpr (StgLet bind expr@(StgLet _ _))
 719   = ($$)
 720       (sep [hang (ptext SLIT("let {"))
 721                 2 (hsep [pprGenStgBinding bind, ptext SLIT("} in")])])
 722       (ppr expr)
 723
 724 -- general case
 725 pprStgExpr (StgLet bind expr)
 726   = sep [hang (ptext SLIT("let {")) 2 (pprGenStgBinding bind),
 727            hang (ptext SLIT("} in ")) 2 (ppr expr)]
 728
 729 pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr)
 730   = sep [hang (ptext SLIT("let-no-escape {"))
 731                 2 (pprGenStgBinding bind),
 732            hang ((<>) (ptext SLIT("} in "))
 733                    (ifPprDebug (
 734                     nest 4 (
 735                       hcat [ptext  SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
 736                              ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
 737                              char ']']))))
 738                 2 (ppr expr)]
 739
 740 pprStgExpr (StgSCC cc expr)
 741   = sep [ hsep [ptext SLIT("_scc_"), ppr cc],
 742           pprStgExpr expr ]
 743
 744 pprStgExpr (StgTick m n expr)
 745   = sep [ hsep [ptext SLIT("_tick_"),  pprModule m,text (show n)],
 746           pprStgExpr expr ]
 747
 748 pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts)
 749   = sep [sep [ptext SLIT("case"),
 750            nest 4 (hsep [pprStgExpr expr,
 751              ifPprDebug (dcolon <+> ppr alt_type)]),
 752            ptext SLIT("of"), ppr bndr, char '{'],
 753            ifPprDebug (
 754            nest 4 (
 755              hcat [ptext  SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
 756                     ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
 757                     ptext SLIT("]; "),
 758                     pprMaybeSRT srt])),
 759            nest 2 (vcat (map pprStgAlt alts)),
 760            char '}']
 761
 762 pprStgAlt :: (Outputable bndr, Outputable occ, Ord occ)
 763           => GenStgAlt bndr occ -> SDoc
 764 pprStgAlt (con, params, _use_mask, expr)
 765   = hang (hsep [ppr con, interppSP params, ptext SLIT("->")])
 766          4 (ppr expr <> semi)
 767
 768 pprStgOp :: StgOp -> SDoc
 769 pprStgOp (StgPrimOp  op)   = ppr op
 770 pprStgOp (StgFCallOp op _) = ppr op
 771
 772 instance Outputable AltType where
 773   ppr PolyAlt        = ptext SLIT("Polymorphic")
 774   ppr (UbxTupAlt tc) = ptext SLIT("UbxTup") <+> ppr tc
 775   ppr (AlgAlt tc)    = ptext SLIT("Alg")    <+> ppr tc
 776   ppr (PrimAlt tc)   = ptext SLIT("Prim")   <+> ppr tc
 777 \end{code}
 778
 779 \begin{code}
 780 #ifdef DEBUG
 781 pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
 782 pprStgLVs lvs
 783   = getPprStyle $ \ sty ->
 784     if userStyle sty || isEmptyUniqSet lvs then
 785         empty
 786     else
 787         hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
 788 #endif
 789 \end{code}
 790
 791 \begin{code}
 792 pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee)
 793           => GenStgRhs bndr bdee -> SDoc
 794
 795 -- special case
 796 pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag srt [{-no args-}] (StgApp func []))
 797   = hcat [ ppr cc,
 798            pp_binder_info bi,
 799            brackets (ifPprDebug (ppr free_var)),
 800            ptext SLIT(" \\"), ppr upd_flag, pprMaybeSRT srt, ptext SLIT(" [] "), ppr func ]
 801
 802 -- general case
 803 pprStgRhs (StgRhsClosure cc bi free_vars upd_flag srt args body)
 804   = hang (hsep [if opt_SccProfilingOn then ppr cc else empty,
 805                 pp_binder_info bi,
 806                 ifPprDebug (brackets (interppSP free_vars)),
 807                 char '\\' <> ppr upd_flag, pprMaybeSRT srt, brackets (interppSP args)])
 808          4 (ppr body)
 809
 810 pprStgRhs (StgRhsCon cc con args)
 811   = hcat [ ppr cc,
 812            space, ppr con, ptext SLIT("! "), brackets (interppSP args)]
 813
 814 pprMaybeSRT :: SRT -> SDoc
 815 pprMaybeSRT (NoSRT) = empty
 816 pprMaybeSRT srt     = ptext SLIT("srt:") <> pprSRT srt
 817 \end{code}