StgSyn.hs 26.4 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

4 5
\section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation}

dterei's avatar
dterei committed
6 7 8 9
This data type represents programs just before code generation (conversion to
@Cmm@): basically, what we have is a stylised form of @CoreSyntax@, the style
being one that happens to be ideally suited to spineless tagless code
generation.
Austin Seipp's avatar
Austin Seipp committed
10
-}
11

12
{-# LANGUAGE CPP #-}
Ian Lynagh's avatar
Ian Lynagh committed
13

14
module StgSyn (
dterei's avatar
dterei committed
15 16
        GenStgArg(..),
        GenStgLiveVars,
17

dterei's avatar
dterei committed
18 19
        GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
        GenStgAlt, AltType(..),
20

dterei's avatar
dterei committed
21
        UpdateFlag(..), isUpdatable,
22

dterei's avatar
dterei committed
23 24 25
        StgBinderInfo,
        noBinderInfo, stgSatOcc, stgUnsatOcc, satCallsOnly,
        combineStgBinderInfo,
26

dterei's avatar
dterei committed
27 28 29
        -- a set of synonyms for the most common (only :-) parameterisation
        StgArg, StgLiveVars,
        StgBinding, StgExpr, StgRhs, StgAlt,
30

dterei's avatar
dterei committed
31 32
        -- StgOp
        StgOp(..),
33

dterei's avatar
dterei committed
34
        -- utils
35
        topStgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity,
36
        isDllConApp,
dterei's avatar
dterei committed
37
        stgArgType,
38
        stripStgTicksTop,
39

Simon Marlow's avatar
Simon Marlow committed
40
        pprStgBinding, pprStgBindings,
dterei's avatar
dterei committed
41
        pprStgLVs
42 43
    ) where

Ian Lynagh's avatar
Ian Lynagh committed
44 45
#include "HsVersions.h"

46 47
import CoreSyn     ( AltCon, Tickish )
import CostCentre  ( CostCentreStack )
48
import Data.List   ( intersperse )
dterei's avatar
dterei committed
49
import DataCon
Ian Lynagh's avatar
Ian Lynagh committed
50
import DynFlags
51
import FastString
dterei's avatar
dterei committed
52 53 54 55
import ForeignCall ( ForeignCall )
import Id
import IdInfo      ( mayHaveCafRefs )
import Literal     ( Literal, literalType )
56
import Module      ( Module )
dterei's avatar
dterei committed
57 58 59 60 61 62 63 64 65 66 67
import Outputable
import Packages    ( isDllName )
import Platform
import PprCore     ( {- instances -} )
import PrimOp      ( PrimOp, PrimCall )
import TyCon       ( PrimRep(..) )
import TyCon       ( TyCon )
import Type        ( Type )
import Type        ( typePrimRep )
import UniqSet
import Unique      ( Unique )
68
import Util
69

Austin Seipp's avatar
Austin Seipp committed
70 71 72
{-
************************************************************************
*                                                                      *
73
\subsection{@GenStgBinding@}
Austin Seipp's avatar
Austin Seipp committed
74 75
*                                                                      *
************************************************************************
76

dterei's avatar
dterei committed
77
As usual, expressions are interesting; other things are boring. Here
78 79 80
are the boring things [except note the @GenStgRhs@], parameterised
with respect to binder and occurrence information (just as in
@CoreSyn@):
Austin Seipp's avatar
Austin Seipp committed
81
-}
82

83
data GenStgBinding bndr occ
dterei's avatar
dterei committed
84 85
  = StgNonRec bndr (GenStgRhs bndr occ)
  | StgRec    [(bndr, GenStgRhs bndr occ)]
86

Austin Seipp's avatar
Austin Seipp committed
87 88 89
{-
************************************************************************
*                                                                      *
90
\subsection{@GenStgArg@}
Austin Seipp's avatar
Austin Seipp committed
91 92 93
*                                                                      *
************************************************************************
-}
94

95
data GenStgArg occ
dterei's avatar
dterei committed
96 97
  = StgVarArg  occ
  | StgLitArg  Literal
98

dterei's avatar
dterei committed
99
-- | Does this constructor application refer to
100 101
-- anything in a different *Windows* DLL?
-- If so, we can't allocate it statically
102 103
isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool
isDllConApp dflags this_mod con args
Ian Lynagh's avatar
Ian Lynagh committed
104
 | platformOS (targetPlatform dflags) == OSMinGW32
105
    = isDllName dflags this_pkg this_mod (dataConName con) || any is_dll_arg args
Ian Lynagh's avatar
Ian Lynagh committed
106
 | otherwise = False
107
  where
108 109
    -- NB: typePrimRep is legit because any free variables won't have
    -- unlifted type (there are no unlifted things at top level)
Ian Lynagh's avatar
Ian Lynagh committed
110
    is_dll_arg :: StgArg -> Bool
111
    is_dll_arg (StgVarArg v) =  isAddrRep (typePrimRep (idType v))
112
                             && isDllName dflags this_pkg this_mod (idName v)
113
    is_dll_arg _             = False
114

Ian Lynagh's avatar
Ian Lynagh committed
115 116
    this_pkg = thisPackage dflags

Gabor Greif's avatar
Gabor Greif committed
117
-- True of machine addresses; these are the things that don't
dterei's avatar
dterei committed
118
-- work across DLLs. The key point here is that VoidRep comes
Gabor Greif's avatar
Gabor Greif committed
119
-- out False, so that a top level nullary GADT constructor is
dterei's avatar
dterei committed
120
-- False for isDllConApp
121 122 123 124 125 126 127 128
--    data T a where
--      T1 :: T Int
-- gives
--    T1 :: forall a. (a~Int) -> T a
-- and hence the top-level binding
--    $WT1 :: T Int
--    $WT1 = T1 Int (Coercion (Refl Int))
-- The coercion argument here gets VoidRep
dterei's avatar
dterei committed
129
isAddrRep :: PrimRep -> Bool
130 131 132 133
isAddrRep AddrRep = True
isAddrRep PtrRep  = True
isAddrRep _       = False

dterei's avatar
dterei committed
134 135 136
-- | Type of an @StgArg@
--
-- Very half baked becase we have lost the type arguments.
137 138 139
stgArgType :: StgArg -> Type
stgArgType (StgVarArg v)   = idType v
stgArgType (StgLitArg lit) = literalType lit
140

141 142 143 144 145 146 147 148

-- | Strip ticks of a given type from an STG expression
stripStgTicksTop :: (Tickish Id -> Bool) -> StgExpr -> ([Tickish Id], StgExpr)
stripStgTicksTop p = go []
   where go ts (StgTick t e) | p t = go (t:ts) e
         go ts other               = (reverse ts, other)


Austin Seipp's avatar
Austin Seipp committed
149 150 151
{-
************************************************************************
*                                                                      *
152
\subsection{STG expressions}
Austin Seipp's avatar
Austin Seipp committed
153 154
*                                                                      *
************************************************************************
155

156 157
The @GenStgExpr@ data type is parameterised on binder and occurrence
info, as before.
158

Austin Seipp's avatar
Austin Seipp committed
159 160
************************************************************************
*                                                                      *
161
\subsubsection{@GenStgExpr@ application}
Austin Seipp's avatar
Austin Seipp committed
162 163
*                                                                      *
************************************************************************
164 165 166

An application is of a function to a list of atoms [not expressions].
Operationally, we want to push the arguments on the stack and call the
dterei's avatar
dterei committed
167
function. (If the arguments were expressions, we would have to build
168 169 170
their closures first.)

There is no constructor for a lone variable; it would appear as
rwbarton's avatar
rwbarton committed
171
@StgApp var []@.
Austin Seipp's avatar
Austin Seipp committed
172 173
-}

174
type GenStgLiveVars occ = UniqSet occ
175

176 177
data GenStgExpr bndr occ
  = StgApp
dterei's avatar
dterei committed
178 179
        occ             -- function
        [GenStgArg occ] -- arguments; may be empty
180

Austin Seipp's avatar
Austin Seipp committed
181 182 183
{-
************************************************************************
*                                                                      *
184
\subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications}
Austin Seipp's avatar
Austin Seipp committed
185 186
*                                                                      *
************************************************************************
187

rwbarton's avatar
rwbarton committed
188
There are specialised forms of application, for constructors,
dterei's avatar
dterei committed
189
primitives, and literals.
Austin Seipp's avatar
Austin Seipp committed
190 191
-}

dterei's avatar
dterei committed
192 193 194 195 196 197 198 199 200 201 202 203
  | StgLit      Literal

        -- StgConApp is vital for returning unboxed tuples
        -- which can't be let-bound first
  | StgConApp   DataCon
                [GenStgArg occ] -- Saturated

  | StgOpApp    StgOp           -- Primitive op or foreign call
                [GenStgArg occ] -- Saturated
                Type            -- Result type
                                -- We need to know this so that we can
                                -- assign result registers
204

Austin Seipp's avatar
Austin Seipp committed
205 206 207
{-
************************************************************************
*                                                                      *
208
\subsubsection{@StgLam@}
Austin Seipp's avatar
Austin Seipp committed
209 210
*                                                                      *
************************************************************************
211

dterei's avatar
dterei committed
212 213
StgLam is used *only* during CoreToStg's work. Before CoreToStg has
finished it encodes (\x -> e) as (let f = \x -> e in f)
Austin Seipp's avatar
Austin Seipp committed
214
-}
215 216

  | StgLam
dterei's avatar
dterei committed
217 218
        [bndr]
        StgExpr    -- Body of lambda
219

Austin Seipp's avatar
Austin Seipp committed
220 221 222
{-
************************************************************************
*                                                                      *
223
\subsubsection{@GenStgExpr@: case-expressions}
Austin Seipp's avatar
Austin Seipp committed
224 225
*                                                                      *
************************************************************************
226 227

This has the same boxed/unboxed business as Core case expressions.
Austin Seipp's avatar
Austin Seipp committed
228 229
-}

230
  | StgCase
dterei's avatar
dterei committed
231 232
        (GenStgExpr bndr occ)
                    -- the thing to examine
233

dterei's avatar
dterei committed
234
        bndr        -- binds the result of evaluating the scrutinee
235

dterei's avatar
dterei committed
236
        AltType
237

dterei's avatar
dterei committed
238 239 240
        [GenStgAlt bndr occ]
                    -- The DEFAULT case is always *first*
                    -- if it is there at all
241

Austin Seipp's avatar
Austin Seipp committed
242 243 244
{-
************************************************************************
*                                                                      *
dterei's avatar
dterei committed
245
\subsubsection{@GenStgExpr@: @let(rec)@-expressions}
Austin Seipp's avatar
Austin Seipp committed
246 247
*                                                                      *
************************************************************************
248 249 250 251 252 253

The various forms of let(rec)-expression encode most of the
interesting things we want to do.
\begin{enumerate}
\item
\begin{verbatim}
dterei's avatar
dterei committed
254
let-closure x = [free-vars] [args] expr
255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293
in e
\end{verbatim}
is equivalent to
\begin{verbatim}
let x = (\free-vars -> \args -> expr) free-vars
\end{verbatim}
\tr{args} may be empty (and is for most closures).  It isn't under
circumstances like this:
\begin{verbatim}
let x = (\y -> y+z)
\end{verbatim}
This gets mangled to
\begin{verbatim}
let-closure x = [z] [y] (y+z)
\end{verbatim}
The idea is that we compile code for @(y+z)@ in an environment in which
@z@ is bound to an offset from \tr{Node}, and @y@ is bound to an
offset from the stack pointer.

(A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)

\item
\begin{verbatim}
let-constructor x = Constructor [args]
in e
\end{verbatim}

(A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)

\item
Letrec-expressions are essentially the same deal as
let-closure/let-constructor, so we use a common structure and
distinguish between them with an @is_recursive@ boolean flag.

\item
\begin{verbatim}
let-unboxed u = an arbitrary arithmetic expression in unboxed values
in e
\end{verbatim}
dterei's avatar
dterei committed
294 295
All the stuff on the RHS must be fully evaluated.
No function calls either!
296 297 298 299 300

(We've backed away from this toward case-expressions with
suitably-magical alts ...)

\item
dterei's avatar
dterei committed
301
~[Advanced stuff here! Not to start with, but makes pattern matching
302 303 304 305 306 307 308
generate more efficient code.]

\begin{verbatim}
let-escapes-not fail = expr
in e'
\end{verbatim}
Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,
dterei's avatar
dterei committed
309
or pass it to another function. All @e'@ will ever do is tail-call @fail@.
310 311 312 313 314 315 316 317
Rather than build a closure for @fail@, all we need do is to record the stack
level at the moment of the @let-escapes-not@; then entering @fail@ is just
a matter of adjusting the stack pointer back down to that point and entering
the code for it.

Another example:
\begin{verbatim}
f x y = let z = huge-expression in
dterei's avatar
dterei committed
318 319 320
        if y==1 then z else
        if y==2 then z else
        1
321 322 323 324 325 326 327
\end{verbatim}

(A let-escapes-not is an @StgLetNoEscape@.)

\item
We may eventually want:
\begin{verbatim}
328
let-literal x = Literal
329 330 331 332 333
in e
\end{verbatim}
\end{enumerate}

And so the code for let(rec)-things:
Austin Seipp's avatar
Austin Seipp committed
334 335
-}

336
  | StgLet
dterei's avatar
dterei committed
337 338
        (GenStgBinding bndr occ)    -- right hand sides (see below)
        (GenStgExpr bndr occ)       -- body
339

340
  | StgLetNoEscape
dterei's avatar
dterei committed
341 342
        (GenStgBinding bndr occ)    -- right hand sides (see below)
        (GenStgExpr bndr occ)       -- body
343

Austin Seipp's avatar
Austin Seipp committed
344
{-
345 346 347 348 349
%************************************************************************
%*                                                                      *
\subsubsection{@GenStgExpr@: @hpc@, @scc@ and other debug annotations}
%*                                                                      *
%************************************************************************
andy@galois.com's avatar
andy@galois.com committed
350

Edward Z. Yang's avatar
Edward Z. Yang committed
351
Finally for @hpc@ expressions we introduce a new STG construct.
Austin Seipp's avatar
Austin Seipp committed
352
-}
andy@galois.com's avatar
andy@galois.com committed
353 354

  | StgTick
355 356
    (Tickish bndr)
    (GenStgExpr bndr occ)       -- sub expression
dterei's avatar
dterei committed
357 358

-- END of GenStgExpr
359

Austin Seipp's avatar
Austin Seipp committed
360 361 362
{-
************************************************************************
*                                                                      *
363
\subsection{STG right-hand sides}
Austin Seipp's avatar
Austin Seipp committed
364 365
*                                                                      *
************************************************************************
366 367 368

Here's the rest of the interesting stuff for @StgLet@s; the first
flavour is for closures:
Austin Seipp's avatar
Austin Seipp committed
369 370
-}

371
data GenStgRhs bndr occ
372
  = StgRhsClosure
dterei's avatar
dterei committed
373 374 375 376 377 378 379 380
        CostCentreStack         -- CCS to be attached (default is CurrentCCS)
        StgBinderInfo           -- Info about how this binder is used (see below)
        [occ]                   -- non-global free vars; a list, rather than
                                -- a set, because order is important
        !UpdateFlag             -- ReEntrant | Updatable | SingleEntry
        [bndr]                  -- arguments; if empty, then not a function;
                                -- as above, order is important.
        (GenStgExpr bndr occ)   -- body
Austin Seipp's avatar
Austin Seipp committed
381 382

{-
383 384 385 386 387 388 389 390 391 392 393 394 395
An example may be in order.  Consider:
\begin{verbatim}
let t = \x -> \y -> ... x ... y ... p ... q in e
\end{verbatim}
Pulling out the free vars and stylising somewhat, we get the equivalent:
\begin{verbatim}
let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
\end{verbatim}
Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are
offsets from @Node@ into the closure, and the code ptr for the closure
will be exactly that in parentheses above.

The second flavour of right-hand-side is for constructors (simple but important):
Austin Seipp's avatar
Austin Seipp committed
396 397
-}

398
  | StgRhsCon
dterei's avatar
dterei committed
399 400 401 402 403 404 405
        CostCentreStack  -- CCS to be attached (default is CurrentCCS).
                         -- Top-level (static) ones will end up with
                         -- DontCareCCS, because we don't count static
                         -- data in heap profiles, and we don't set CCCS
                         -- from static closure.
        DataCon          -- constructor
        [GenStgArg occ]  -- args
406

407
stgRhsArity :: StgRhs -> Int
408
stgRhsArity (StgRhsClosure _ _ _ _ bndrs _)
409 410
  = ASSERT( all isId bndrs ) length bndrs
  -- The arity never includes type parameters, but they should have gone by now
411 412
stgRhsArity (StgRhsCon _ _ _) = 0

413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463
-- Note [CAF consistency]
-- ~~~~~~~~~~~~~~~~~~~~~~
--
-- `topStgBindHasCafRefs` is only used by an assert (`consistentCafInfo` in
-- `CoreToStg`) to make sure CAF-ness predicted by `TidyPgm` is consistent with
-- reality.
--
-- Specifically, if the RHS mentions any Id that itself is marked
-- `MayHaveCafRefs`; or if the binding is a top-level updateable thunk; then the
-- `Id` for the binding should be marked `MayHaveCafRefs`. The potential trouble
-- is that `TidyPgm` computed the CAF info on the `Id` but some transformations
-- have taken place since then.

topStgBindHasCafRefs :: GenStgBinding bndr Id -> Bool
topStgBindHasCafRefs (StgNonRec _ rhs)
  = topRhsHasCafRefs rhs
topStgBindHasCafRefs (StgRec binds)
  = any topRhsHasCafRefs (map snd binds)

topRhsHasCafRefs :: GenStgRhs bndr Id -> Bool
topRhsHasCafRefs (StgRhsClosure _ _ _ upd _ body)
  = -- See Note [CAF consistency]
    isUpdatable upd || exprHasCafRefs body
topRhsHasCafRefs (StgRhsCon _ _ args)
  = any stgArgHasCafRefs args

exprHasCafRefs :: GenStgExpr bndr Id -> Bool
exprHasCafRefs (StgApp f args)
  = stgIdHasCafRefs f || any stgArgHasCafRefs args
exprHasCafRefs StgLit{}
  = False
exprHasCafRefs (StgConApp _ args)
  = any stgArgHasCafRefs args
exprHasCafRefs (StgOpApp _ args _)
  = any stgArgHasCafRefs args
exprHasCafRefs (StgLam _ body)
  = exprHasCafRefs body
exprHasCafRefs (StgCase scrt _ _ alts)
  = exprHasCafRefs scrt || any altHasCafRefs alts
exprHasCafRefs (StgLet bind body)
  = bindHasCafRefs bind || exprHasCafRefs body
exprHasCafRefs (StgLetNoEscape bind body)
  = bindHasCafRefs bind || exprHasCafRefs body
exprHasCafRefs (StgTick _ expr)
  = exprHasCafRefs expr

bindHasCafRefs :: GenStgBinding bndr Id -> Bool
bindHasCafRefs (StgNonRec _ rhs)
  = rhsHasCafRefs rhs
bindHasCafRefs (StgRec binds)
  = any rhsHasCafRefs (map snd binds)
464

twanvl's avatar
twanvl committed
465
rhsHasCafRefs :: GenStgRhs bndr Id -> Bool
466 467
rhsHasCafRefs (StgRhsClosure _ _ _ _ _ body)
  = exprHasCafRefs body
468 469 470
rhsHasCafRefs (StgRhsCon _ _ args)
  = any stgArgHasCafRefs args

471
altHasCafRefs :: GenStgAlt bndr Id -> Bool
472
altHasCafRefs (_, _, rhs) = exprHasCafRefs rhs
473

twanvl's avatar
twanvl committed
474
stgArgHasCafRefs :: GenStgArg Id -> Bool
475 476 477 478 479 480 481 482 483 484 485
stgArgHasCafRefs (StgVarArg id)
  = stgIdHasCafRefs id
stgArgHasCafRefs _
  = False

stgIdHasCafRefs :: Id -> Bool
stgIdHasCafRefs id =
  -- We are looking for occurrences of an Id that is bound at top level, and may
  -- have CAF refs. At this point (after TidyPgm) top-level Ids (whether
  -- imported or defined in this module) are GlobalIds, so the test is easy.
  isGlobalId id && mayHaveCafRefs (idCafInfo id)
486

Austin Seipp's avatar
Austin Seipp committed
487 488
-- Here's the @StgBinderInfo@ type, and its combining op:

489
data StgBinderInfo
490
  = NoStgBinderInfo
dterei's avatar
dterei committed
491 492 493 494
  | SatCallsOnly        -- All occurrences are *saturated* *function* calls
                        -- This means we don't need to build an info table and
                        -- slow entry code for the thing
                        -- Thunks never get this value
495

twanvl's avatar
twanvl committed
496
noBinderInfo, stgUnsatOcc, stgSatOcc :: StgBinderInfo
497 498 499
noBinderInfo = NoStgBinderInfo
stgUnsatOcc  = NoStgBinderInfo
stgSatOcc    = SatCallsOnly
500

501 502 503
satCallsOnly :: StgBinderInfo -> Bool
satCallsOnly SatCallsOnly    = True
satCallsOnly NoStgBinderInfo = False
504 505

combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
506
combineStgBinderInfo SatCallsOnly SatCallsOnly = SatCallsOnly
twanvl's avatar
twanvl committed
507
combineStgBinderInfo _            _            = NoStgBinderInfo
508

509
--------------
twanvl's avatar
twanvl committed
510
pp_binder_info :: StgBinderInfo -> SDoc
511
pp_binder_info NoStgBinderInfo = empty
512
pp_binder_info SatCallsOnly    = text "sat-only"
513

Austin Seipp's avatar
Austin Seipp committed
514 515 516
{-
************************************************************************
*                                                                      *
517
\subsection[Stg-case-alternatives]{STG case alternatives}
Austin Seipp's avatar
Austin Seipp committed
518 519
*                                                                      *
************************************************************************
520

521
Very like in @CoreSyntax@ (except no type-world stuff).
522

523
The type constructor is guaranteed not to be abstract; that is, we can
dterei's avatar
dterei committed
524 525
see its representation. This is important because the code generator
uses it to determine return conventions etc. But it's not trivial
526
where there's a module loop involved, because some versions of a type
dterei's avatar
dterei committed
527
constructor might not have all the constructors visible. So
528 529 530
mkStgAlgAlts (in CoreToStg) ensures that it gets the TyCon from the
constructors or literals (which are guaranteed to have the Real McCoy)
rather than from the scrutinee type.
Austin Seipp's avatar
Austin Seipp committed
531
-}
532

533
type GenStgAlt bndr occ
dterei's avatar
dterei committed
534 535 536
  = (AltCon,            -- alts: data constructor,
     [bndr],            -- constructor's parameters,
     GenStgExpr bndr occ)       -- ...right-hand side.
537 538

data AltType
dterei's avatar
dterei committed
539
  = PolyAlt             -- Polymorphic (a type variable)
540
  | UbxTupAlt Int       -- Unboxed tuple of this arity
dterei's avatar
dterei committed
541 542
  | AlgAlt    TyCon     -- Algebraic data type; the AltCons will be DataAlts
  | PrimAlt   TyCon     -- Primitive data type; the AltCons will be LitAlts
543

Austin Seipp's avatar
Austin Seipp committed
544 545 546
{-
************************************************************************
*                                                                      *
547
\subsection[Stg]{The Plain STG parameterisation}
Austin Seipp's avatar
Austin Seipp committed
548 549
*                                                                      *
************************************************************************
550 551

This happens to be the only one we use at the moment.
Austin Seipp's avatar
Austin Seipp committed
552
-}
553

dterei's avatar
dterei committed
554 555 556 557 558 559
type StgBinding  = GenStgBinding  Id Id
type StgArg      = GenStgArg      Id
type StgLiveVars = GenStgLiveVars Id
type StgExpr     = GenStgExpr     Id Id
type StgRhs      = GenStgRhs      Id Id
type StgAlt      = GenStgAlt      Id Id
560

Austin Seipp's avatar
Austin Seipp committed
561 562 563
{-
************************************************************************
*                                                                      *
564
\subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
Austin Seipp's avatar
Austin Seipp committed
565 566
*                                                                      *
************************************************************************
567

568
This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
569

570
A @ReEntrant@ closure may be entered multiple times, but should not be
dterei's avatar
dterei committed
571 572
updated or blackholed. An @Updatable@ closure should be updated after
evaluation (and may be blackholed during evaluation). A @SingleEntry@
573 574
closure will only be entered once, and so need not be updated but may
safely be blackholed.
Austin Seipp's avatar
Austin Seipp committed
575
-}
576

577
data UpdateFlag = ReEntrant | Updatable | SingleEntry
578

579
instance Outputable UpdateFlag where
dterei's avatar
dterei committed
580 581 582 583
    ppr u = char $ case u of
                       ReEntrant   -> 'r'
                       Updatable   -> 'u'
                       SingleEntry -> 's'
584

twanvl's avatar
twanvl committed
585
isUpdatable :: UpdateFlag -> Bool
586 587 588 589
isUpdatable ReEntrant   = False
isUpdatable SingleEntry = False
isUpdatable Updatable   = True

Austin Seipp's avatar
Austin Seipp committed
590 591 592
{-
************************************************************************
*                                                                      *
593
\subsubsection{StgOp}
Austin Seipp's avatar
Austin Seipp committed
594 595
*                                                                      *
************************************************************************
596 597 598 599

An StgOp allows us to group together PrimOps and ForeignCalls.
It's quite useful to move these around together, notably
in StgOpApp and COpStmt.
Austin Seipp's avatar
Austin Seipp committed
600
-}
601

dterei's avatar
dterei committed
602 603
data StgOp
  = StgPrimOp  PrimOp
604

dterei's avatar
dterei committed
605
  | StgPrimCallOp PrimCall
606

dterei's avatar
dterei committed
607 608 609 610
  | StgFCallOp ForeignCall Unique
        -- The Unique is occasionally needed by the C pretty-printer
        -- (which lacks a unique supply), notably when generating a
        -- typedef for foreign-export-dynamic
611

Austin Seipp's avatar
Austin Seipp committed
612 613 614
{-
************************************************************************
*                                                                      *
615
\subsection[Stg-pretty-printing]{Pretty-printing}
Austin Seipp's avatar
Austin Seipp committed
616 617
*                                                                      *
************************************************************************
618 619 620

Robin Popplestone asked for semi-colon separators on STG binds; here's
hoping he likes terminators instead...  Ditto for case alternatives.
Austin Seipp's avatar
Austin Seipp committed
621
-}
622

623
pprGenStgBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
624
                 => GenStgBinding bndr bdee -> SDoc
625

626
pprGenStgBinding (StgNonRec bndr rhs)
627
  = hang (hsep [pprBndr LetBind bndr, equals])
628
        4 (ppr rhs <> semi)
629

630
pprGenStgBinding (StgRec pairs)
631 632
  = vcat $ ifPprDebug (text "{- StgRec (begin) -}") :
           map (ppr_bind) pairs ++ [ifPprDebug (text "{- StgRec (end) -}")]
633
  where
634
    ppr_bind (bndr, expr)
635
      = hang (hsep [pprBndr LetBind bndr, equals])
636
             4 (ppr expr <> semi)
637

dterei's avatar
dterei committed
638
pprStgBinding :: StgBinding -> SDoc
639
pprStgBinding  bind  = pprGenStgBinding bind
sof's avatar
sof committed
640

641
pprStgBindings :: [StgBinding] -> SDoc
642
pprStgBindings binds = vcat $ intersperse blankLine (map pprGenStgBinding binds)
643

644 645
instance (Outputable bdee) => Outputable (GenStgArg bdee) where
    ppr = pprStgArg
646

647
instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
648
                => Outputable (GenStgBinding bndr bdee) where
sof's avatar
sof committed
649
    ppr = pprGenStgBinding
650

651
instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
652
                => Outputable (GenStgExpr bndr bdee) where
653 654
    ppr = pprStgExpr

655
instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
656
                => Outputable (GenStgRhs bndr bdee) where
657
    ppr rhs = pprStgRhs rhs
658

659 660
pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
pprStgArg (StgVarArg var) = ppr var
661
pprStgArg (StgLitArg con) = ppr con
662

663
pprStgExpr :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
664
           => GenStgExpr bndr bdee -> SDoc
665
-- special case
666
pprStgExpr (StgLit lit)     = ppr lit
667 668

-- general case
669
pprStgExpr (StgApp func args)
dterei's avatar
dterei committed
670
  = hang (ppr func) 4 (sep (map (ppr) args))
671

672
pprStgExpr (StgConApp con args)
673
  = hsep [ ppr con, brackets (interppSP args)]
674

675 676
pprStgExpr (StgOpApp op args _)
  = hsep [ pprStgOp op, brackets (interppSP args)]
677

678
pprStgExpr (StgLam bndrs body)
679
  = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) bndrs)
680
            <+> text "->",
dterei's avatar
dterei committed
681
         pprStgExpr body ]
682
  where ppr_list = brackets . fsep . punctuate comma
683 684

-- special case: let v = <very specific thing>
dterei's avatar
dterei committed
685 686 687 688
--               in
--               let ...
--               in
--               ...
689 690 691
--
-- Very special!  Suspicious! (SLPJ)

692 693
{-
pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
dterei's avatar
dterei committed
694
                        expr@(StgLet _ _))
sof's avatar
sof committed
695
  = ($$)
696
      (hang (hcat [text "let { ", ppr bndr, ptext (sLit " = "),
dterei's avatar
dterei committed
697 698
                          ppr cc,
                          pp_binder_info bi,
699 700
                          text " [", ifPprDebug (interppSP free_vars), ptext (sLit "] \\"),
                          ppr upd_flag, text " [",
dterei's avatar
dterei committed
701
                          interppSP args, char ']'])
702
            8 (sep [hsep [ppr rhs, text "} in"]]))
703
      (ppr expr)
704
-}
705 706 707

-- special case: let ... in let ...

708
pprStgExpr (StgLet bind expr@(StgLet _ _))
sof's avatar
sof committed
709
  = ($$)
710 711
      (sep [hang (text "let {")
                2 (hsep [pprGenStgBinding bind, text "} in"])])
712
      (ppr expr)
713 714

-- general case
715
pprStgExpr (StgLet bind expr)
716 717
  = sep [hang (text "let {") 2 (pprGenStgBinding bind),
           hang (text "} in ") 2 (ppr expr)]
718

719
pprStgExpr (StgLetNoEscape bind expr)
720
  = sep [hang (text "let-no-escape {")
dterei's avatar
dterei committed
721
                2 (pprGenStgBinding bind),
722
           hang (text "} in ")
dterei's avatar
dterei committed
723
                2 (ppr expr)]
724

725 726 727 728 729
pprStgExpr (StgTick tickish expr)
  = sdocWithDynFlags $ \dflags ->
    if gopt Opt_PprShowTicks dflags
    then sep [ ppr tickish, pprStgExpr expr ]
    else pprStgExpr expr
730

andy@galois.com's avatar
andy@galois.com committed
731

732
pprStgExpr (StgCase expr bndr alt_type alts)
733
  = sep [sep [text "case",
dterei's avatar
dterei committed
734 735
           nest 4 (hsep [pprStgExpr expr,
             ifPprDebug (dcolon <+> ppr alt_type)]),
736
           text "of", pprBndr CaseBind bndr, char '{'],
dterei's avatar
dterei committed
737 738
           nest 2 (vcat (map pprStgAlt alts)),
           char '}']
739

740
pprStgAlt :: (OutputableBndr bndr, Outputable occ, Ord occ)
twanvl's avatar
twanvl committed
741
          => GenStgAlt bndr occ -> SDoc
742
pprStgAlt (con, params, expr)
743
  = hang (hsep [ppr con, sep (map (pprBndr CaseBind) params), text "->"])
dterei's avatar
dterei committed
744
         4 (ppr expr <> semi)
745

twanvl's avatar
twanvl committed
746
pprStgOp :: StgOp -> SDoc
747
pprStgOp (StgPrimOp  op)   = ppr op
748
pprStgOp (StgPrimCallOp op)= ppr op
749
pprStgOp (StgFCallOp op _) = ppr op
750 751

instance Outputable AltType where
752 753 754 755
  ppr PolyAlt        = text "Polymorphic"
  ppr (UbxTupAlt n)  = text "UbxTup" <+> ppr n
  ppr (AlgAlt tc)    = text "Alg"    <+> ppr tc
  ppr (PrimAlt tc)   = text "Prim"   <+> ppr tc
756

757 758 759 760
pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
pprStgLVs lvs
  = getPprStyle $ \ sty ->
    if userStyle sty || isEmptyUniqSet lvs then
dterei's avatar
dterei committed
761
        empty
762
    else
dterei's avatar
dterei committed
763
        hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
764

765
pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
766
          => GenStgRhs bndr bdee -> SDoc
767 768

-- special case
769
pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func []))
770
  = hcat [ ppr cc,
dterei's avatar
dterei committed
771 772
           pp_binder_info bi,
           brackets (ifPprDebug (ppr free_var)),
773
           text " \\", ppr upd_flag, ptext (sLit " [] "), ppr func ]
774

775
-- general case
776
pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body)
777
  = sdocWithDynFlags $ \dflags ->
ian@well-typed.com's avatar
ian@well-typed.com committed
778
    hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty,
dterei's avatar
dterei committed
779 780
                pp_binder_info bi,
                ifPprDebug (brackets (interppSP free_vars)),
781
                char '\\' <> ppr upd_flag, brackets (interppSP args)])
dterei's avatar
dterei committed
782
         4 (ppr body)
783

784
pprStgRhs (StgRhsCon cc con args)
785
  = hcat [ ppr cc,
786
           space, ppr con, text "! ", brackets (interppSP args)]