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