StgSyn.hs 28.6 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 35
        -- SRTs
        SRT(..),
36

dterei's avatar
dterei committed
37 38
        -- utils
        stgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity,
39
        isDllConApp,
dterei's avatar
dterei committed
40
        stgArgType,
41

Simon Marlow's avatar
Simon Marlow committed
42
        pprStgBinding, pprStgBindings,
dterei's avatar
dterei committed
43
        pprStgLVs
44 45
    ) where

Ian Lynagh's avatar
Ian Lynagh committed
46 47
#include "HsVersions.h"

48
import Bitmap
dterei's avatar
dterei committed
49 50 51
import CoreSyn     ( AltCon )
import CostCentre  ( CostCentreStack, CostCentre )
import DataCon
Ian Lynagh's avatar
Ian Lynagh committed
52
import DynFlags
53
import FastString
dterei's avatar
dterei committed
54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69
import ForeignCall ( ForeignCall )
import Id
import IdInfo      ( mayHaveCafRefs )
import Literal     ( Literal, literalType )
import Module
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 )
70
import Util
dterei's avatar
dterei committed
71
import VarSet      ( IdSet, isEmptyVarSet )
72

Austin Seipp's avatar
Austin Seipp committed
73 74 75
{-
************************************************************************
*                                                                      *
76
\subsection{@GenStgBinding@}
Austin Seipp's avatar
Austin Seipp committed
77 78
*                                                                      *
************************************************************************
79

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

85
There is one SRT for each group of bindings.
Austin Seipp's avatar
Austin Seipp committed
86
-}
87

88
data GenStgBinding bndr occ
dterei's avatar
dterei committed
89 90
  = StgNonRec bndr (GenStgRhs bndr occ)
  | StgRec    [(bndr, GenStgRhs bndr occ)]
91

Austin Seipp's avatar
Austin Seipp committed
92 93 94
{-
************************************************************************
*                                                                      *
95
\subsection{@GenStgArg@}
Austin Seipp's avatar
Austin Seipp committed
96 97 98
*                                                                      *
************************************************************************
-}
99

100
data GenStgArg occ
dterei's avatar
dterei committed
101 102
  = StgVarArg  occ
  | StgLitArg  Literal
103

dterei's avatar
dterei committed
104
-- | Does this constructor application refer to
105 106
-- anything in a different *Windows* DLL?
-- If so, we can't allocate it statically
107 108
isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool
isDllConApp dflags this_mod con args
Ian Lynagh's avatar
Ian Lynagh committed
109
 | platformOS (targetPlatform dflags) == OSMinGW32
110
    = isDllName dflags this_pkg this_mod (dataConName con) || any is_dll_arg args
Ian Lynagh's avatar
Ian Lynagh committed
111
 | otherwise = False
112
  where
113 114
    -- 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
115
    is_dll_arg :: StgArg -> Bool
116
    is_dll_arg (StgVarArg v) =  isAddrRep (typePrimRep (idType v))
117
                             && isDllName dflags this_pkg this_mod (idName v)
118
    is_dll_arg _             = False
119

Ian Lynagh's avatar
Ian Lynagh committed
120 121
    this_pkg = thisPackage dflags

Gabor Greif's avatar
Gabor Greif committed
122
-- True of machine addresses; these are the things that don't
dterei's avatar
dterei committed
123
-- work across DLLs. The key point here is that VoidRep comes
Gabor Greif's avatar
Gabor Greif committed
124
-- out False, so that a top level nullary GADT constructor is
dterei's avatar
dterei committed
125
-- False for isDllConApp
126 127 128 129 130 131 132 133
--    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
134
isAddrRep :: PrimRep -> Bool
135 136 137 138
isAddrRep AddrRep = True
isAddrRep PtrRep  = True
isAddrRep _       = False

dterei's avatar
dterei committed
139 140 141
-- | Type of an @StgArg@
--
-- Very half baked becase we have lost the type arguments.
142 143 144
stgArgType :: StgArg -> Type
stgArgType (StgVarArg v)   = idType v
stgArgType (StgLitArg lit) = literalType lit
145

Austin Seipp's avatar
Austin Seipp committed
146 147 148
{-
************************************************************************
*                                                                      *
149
\subsection{STG expressions}
Austin Seipp's avatar
Austin Seipp committed
150 151
*                                                                      *
************************************************************************
152

153 154
The @GenStgExpr@ data type is parameterised on binder and occurrence
info, as before.
155

Austin Seipp's avatar
Austin Seipp committed
156 157
************************************************************************
*                                                                      *
158
\subsubsection{@GenStgExpr@ application}
Austin Seipp's avatar
Austin Seipp committed
159 160
*                                                                      *
************************************************************************
161 162 163

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
164
function. (If the arguments were expressions, we would have to build
165 166 167 168
their closures first.)

There is no constructor for a lone variable; it would appear as
@StgApp var [] _@.
Austin Seipp's avatar
Austin Seipp committed
169 170
-}

171
type GenStgLiveVars occ = UniqSet occ
172

173 174
data GenStgExpr bndr occ
  = StgApp
dterei's avatar
dterei committed
175 176
        occ             -- function
        [GenStgArg occ] -- arguments; may be empty
177

Austin Seipp's avatar
Austin Seipp committed
178 179 180
{-
************************************************************************
*                                                                      *
181
\subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications}
Austin Seipp's avatar
Austin Seipp committed
182 183
*                                                                      *
************************************************************************
184

dterei's avatar
dterei committed
185 186
There are a specialised forms of application, for constructors,
primitives, and literals.
Austin Seipp's avatar
Austin Seipp committed
187 188
-}

dterei's avatar
dterei committed
189 190 191 192 193 194 195 196 197 198 199 200
  | 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
201

Austin Seipp's avatar
Austin Seipp committed
202 203 204
{-
************************************************************************
*                                                                      *
205
\subsubsection{@StgLam@}
Austin Seipp's avatar
Austin Seipp committed
206 207
*                                                                      *
************************************************************************
208

dterei's avatar
dterei committed
209 210
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
211
-}
212 213

  | StgLam
dterei's avatar
dterei committed
214 215
        [bndr]
        StgExpr    -- Body of lambda
216

Austin Seipp's avatar
Austin Seipp committed
217 218 219
{-
************************************************************************
*                                                                      *
220
\subsubsection{@GenStgExpr@: case-expressions}
Austin Seipp's avatar
Austin Seipp committed
221 222
*                                                                      *
************************************************************************
223 224

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

227
  | StgCase
dterei's avatar
dterei committed
228 229
        (GenStgExpr bndr occ)
                    -- the thing to examine
230

dterei's avatar
dterei committed
231 232 233 234
        (GenStgLiveVars occ)
                    -- Live vars of whole case expression,
                    -- plus everything that happens after the case
                    -- i.e., those which mustn't be overwritten
235

dterei's avatar
dterei committed
236 237 238 239 240 241 242
        (GenStgLiveVars occ)
                    -- Live vars of RHSs (plus what happens afterwards)
                    -- i.e., those which must be saved before eval.
                    --
                    -- note that an alt's constructor's
                    -- binder-variables are NOT counted in the
                    -- free vars for the alt's RHS
243

dterei's avatar
dterei committed
244
        bndr        -- binds the result of evaluating the scrutinee
245

dterei's avatar
dterei committed
246
        SRT         -- The SRT for the continuation
247

dterei's avatar
dterei committed
248
        AltType
249

dterei's avatar
dterei committed
250 251 252
        [GenStgAlt bndr occ]
                    -- The DEFAULT case is always *first*
                    -- if it is there at all
253

Austin Seipp's avatar
Austin Seipp committed
254 255 256
{-
************************************************************************
*                                                                      *
dterei's avatar
dterei committed
257
\subsubsection{@GenStgExpr@: @let(rec)@-expressions}
Austin Seipp's avatar
Austin Seipp committed
258 259
*                                                                      *
************************************************************************
260 261 262 263 264 265

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
266
let-closure x = [free-vars] [args] expr
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 294 295 296 297 298 299 300 301 302 303 304 305
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
306 307
All the stuff on the RHS must be fully evaluated.
No function calls either!
308 309 310 311 312

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

\item
dterei's avatar
dterei committed
313
~[Advanced stuff here! Not to start with, but makes pattern matching
314 315 316 317 318 319 320
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
321
or pass it to another function. All @e'@ will ever do is tail-call @fail@.
322 323 324 325 326 327 328 329
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
330 331 332
        if y==1 then z else
        if y==2 then z else
        1
333 334 335 336 337 338 339
\end{verbatim}

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

\item
We may eventually want:
\begin{verbatim}
340
let-literal x = Literal
341 342 343 344 345
in e
\end{verbatim}
\end{enumerate}

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

348
  | StgLet
dterei's avatar
dterei committed
349 350
        (GenStgBinding bndr occ)    -- right hand sides (see below)
        (GenStgExpr bndr occ)       -- body
351

dterei's avatar
dterei committed
352 353 354
  | StgLetNoEscape                  -- remember: ``advanced stuff''
        (GenStgLiveVars occ)        -- Live in the whole let-expression
                                    -- Mustn't overwrite these stack slots
dterei's avatar
dterei committed
355
                                    -- _Doesn't_ include binders of the let(rec).
356

dterei's avatar
dterei committed
357 358 359
        (GenStgLiveVars occ)        -- Live in the right hand sides (only)
                                    -- These are the ones which must be saved on
                                    -- the stack if they aren't there already
dterei's avatar
dterei committed
360
                                    -- _Does_ include binders of the let(rec) if recursive.
361

dterei's avatar
dterei committed
362 363
        (GenStgBinding bndr occ)    -- right hand sides (see below)
        (GenStgExpr bndr occ)       -- body
364

Austin Seipp's avatar
Austin Seipp committed
365 366 367
{-
************************************************************************
*                                                                      *
368
\subsubsection{@GenStgExpr@: @scc@ expressions}
Austin Seipp's avatar
Austin Seipp committed
369 370
*                                                                      *
************************************************************************
371

dterei's avatar
dterei committed
372
For @scc@ expressions we introduce a new STG construct.
Austin Seipp's avatar
Austin Seipp committed
373
-}
374 375

  | StgSCC
dterei's avatar
dterei committed
376 377 378 379
        CostCentre             -- label of SCC expression
        !Bool                  -- bump the entry count?
        !Bool                  -- push the cost centre?
        (GenStgExpr bndr occ)  -- scc expression
andy@galois.com's avatar
andy@galois.com committed
380

Austin Seipp's avatar
Austin Seipp committed
381 382 383
{-
************************************************************************
*                                                                      *
andy@galois.com's avatar
andy@galois.com committed
384
\subsubsection{@GenStgExpr@: @hpc@ expressions}
Austin Seipp's avatar
Austin Seipp committed
385 386
*                                                                      *
************************************************************************
andy@galois.com's avatar
andy@galois.com committed
387

Edward Z. Yang's avatar
Edward Z. Yang committed
388
Finally for @hpc@ expressions we introduce a new STG construct.
Austin Seipp's avatar
Austin Seipp committed
389
-}
andy@galois.com's avatar
andy@galois.com committed
390 391

  | StgTick
dterei's avatar
dterei committed
392 393 394 395 396
        Module                 -- the module of the source of this tick
        Int                    -- tick number
        (GenStgExpr bndr occ)  -- sub expression

-- END of GenStgExpr
397

Austin Seipp's avatar
Austin Seipp committed
398 399 400
{-
************************************************************************
*                                                                      *
401
\subsection{STG right-hand sides}
Austin Seipp's avatar
Austin Seipp committed
402 403
*                                                                      *
************************************************************************
404 405 406

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

409
data GenStgRhs bndr occ
410
  = StgRhsClosure
dterei's avatar
dterei committed
411 412 413 414 415 416 417 418 419
        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
        SRT                     -- The SRT reference
        [bndr]                  -- arguments; if empty, then not a function;
                                -- as above, order is important.
        (GenStgExpr bndr occ)   -- body
Austin Seipp's avatar
Austin Seipp committed
420 421

{-
422 423 424 425 426 427 428 429 430 431 432 433 434
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
435 436
-}

437
  | StgRhsCon
dterei's avatar
dterei committed
438 439 440 441 442 443 444
        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
445

446
stgRhsArity :: StgRhs -> Int
dterei's avatar
dterei committed
447
stgRhsArity (StgRhsClosure _ _ _ _ _ bndrs _)
448 449
  = ASSERT( all isId bndrs ) length bndrs
  -- The arity never includes type parameters, but they should have gone by now
450 451 452 453 454 455
stgRhsArity (StgRhsCon _ _ _) = 0

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

twanvl's avatar
twanvl committed
456
rhsHasCafRefs :: GenStgRhs bndr Id -> Bool
dterei's avatar
dterei committed
457
rhsHasCafRefs (StgRhsClosure _ _ _ upd srt _ _)
458 459 460 461
  = isUpdatable upd || nonEmptySRT srt
rhsHasCafRefs (StgRhsCon _ _ args)
  = any stgArgHasCafRefs args

twanvl's avatar
twanvl committed
462
stgArgHasCafRefs :: GenStgArg Id -> Bool
463 464
stgArgHasCafRefs (StgVarArg id) = mayHaveCafRefs (idCafInfo id)
stgArgHasCafRefs _ = False
465

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

468
data StgBinderInfo
469
  = NoStgBinderInfo
dterei's avatar
dterei committed
470 471 472 473
  | 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
474

twanvl's avatar
twanvl committed
475
noBinderInfo, stgUnsatOcc, stgSatOcc :: StgBinderInfo
476 477 478
noBinderInfo = NoStgBinderInfo
stgUnsatOcc  = NoStgBinderInfo
stgSatOcc    = SatCallsOnly
479

480 481 482
satCallsOnly :: StgBinderInfo -> Bool
satCallsOnly SatCallsOnly    = True
satCallsOnly NoStgBinderInfo = False
483 484

combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
485
combineStgBinderInfo SatCallsOnly SatCallsOnly = SatCallsOnly
twanvl's avatar
twanvl committed
486
combineStgBinderInfo _            _            = NoStgBinderInfo
487

488
--------------
twanvl's avatar
twanvl committed
489
pp_binder_info :: StgBinderInfo -> SDoc
490
pp_binder_info NoStgBinderInfo = empty
Ian Lynagh's avatar
Ian Lynagh committed
491
pp_binder_info SatCallsOnly    = ptext (sLit "sat-only")
492

Austin Seipp's avatar
Austin Seipp committed
493 494 495
{-
************************************************************************
*                                                                      *
496
\subsection[Stg-case-alternatives]{STG case alternatives}
Austin Seipp's avatar
Austin Seipp committed
497 498
*                                                                      *
************************************************************************
499

500
Very like in @CoreSyntax@ (except no type-world stuff).
501

502
The type constructor is guaranteed not to be abstract; that is, we can
dterei's avatar
dterei committed
503 504
see its representation. This is important because the code generator
uses it to determine return conventions etc. But it's not trivial
505
where there's a moduule loop involved, because some versions of a type
dterei's avatar
dterei committed
506
constructor might not have all the constructors visible. So
507 508 509
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
510
-}
511

512
type GenStgAlt bndr occ
dterei's avatar
dterei committed
513 514 515 516 517 518 519
  = (AltCon,            -- alts: data constructor,
     [bndr],            -- constructor's parameters,
     [Bool],            -- "use mask", same length as
                        -- parameters; a True in a
                        -- param's position if it is
                        -- used in the ...
     GenStgExpr bndr occ)       -- ...right-hand side.
520 521

data AltType
dterei's avatar
dterei committed
522
  = PolyAlt             -- Polymorphic (a type variable)
523
  | UbxTupAlt Int       -- Unboxed tuple of this arity
dterei's avatar
dterei committed
524 525
  | AlgAlt    TyCon     -- Algebraic data type; the AltCons will be DataAlts
  | PrimAlt   TyCon     -- Primitive data type; the AltCons will be LitAlts
526

Austin Seipp's avatar
Austin Seipp committed
527 528 529
{-
************************************************************************
*                                                                      *
530
\subsection[Stg]{The Plain STG parameterisation}
Austin Seipp's avatar
Austin Seipp committed
531 532
*                                                                      *
************************************************************************
533 534

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

dterei's avatar
dterei committed
537 538 539 540 541 542
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
543

Austin Seipp's avatar
Austin Seipp committed
544 545 546
{-
************************************************************************
*                                                                      *
547
\subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
Austin Seipp's avatar
Austin Seipp committed
548 549
*                                                                      *
************************************************************************
550

551
This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
552

553
A @ReEntrant@ closure may be entered multiple times, but should not be
dterei's avatar
dterei committed
554 555
updated or blackholed. An @Updatable@ closure should be updated after
evaluation (and may be blackholed during evaluation). A @SingleEntry@
556 557
closure will only be entered once, and so need not be updated but may
safely be blackholed.
Austin Seipp's avatar
Austin Seipp committed
558
-}
559

560
data UpdateFlag = ReEntrant | Updatable | SingleEntry
561

562
instance Outputable UpdateFlag where
dterei's avatar
dterei committed
563 564 565 566
    ppr u = char $ case u of
                       ReEntrant   -> 'r'
                       Updatable   -> 'u'
                       SingleEntry -> 's'
567

twanvl's avatar
twanvl committed
568
isUpdatable :: UpdateFlag -> Bool
569 570 571 572
isUpdatable ReEntrant   = False
isUpdatable SingleEntry = False
isUpdatable Updatable   = True

Austin Seipp's avatar
Austin Seipp committed
573 574 575
{-
************************************************************************
*                                                                      *
576
\subsubsection{StgOp}
Austin Seipp's avatar
Austin Seipp committed
577 578
*                                                                      *
************************************************************************
579 580 581 582

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
583
-}
584

dterei's avatar
dterei committed
585 586
data StgOp
  = StgPrimOp  PrimOp
587

dterei's avatar
dterei committed
588
  | StgPrimCallOp PrimCall
589

dterei's avatar
dterei committed
590 591 592 593
  | 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
594

Austin Seipp's avatar
Austin Seipp committed
595 596 597
{-
************************************************************************
*                                                                      *
598
\subsubsection[Static Reference Tables]{@SRT@}
Austin Seipp's avatar
Austin Seipp committed
599 600
*                                                                      *
************************************************************************
601

dterei's avatar
dterei committed
602
There is one SRT per top-level function group. Each local binding and
603 604 605
case expression within this binding group has a subrange of the whole
SRT, expressed as an offset and length.

dterei's avatar
dterei committed
606
In CoreToStg we collect the list of CafRefs at each SRT site, which is later
607
converted into the length and offset form by the SRT pass.
Austin Seipp's avatar
Austin Seipp committed
608
-}
609

dterei's avatar
dterei committed
610 611 612 613 614 615
data SRT
  = NoSRT
  | SRTEntries IdSet
        -- generated by CoreToStg
  | SRT !Int{-offset-} !Int{-length-} !Bitmap{-bitmap-}
        -- generated by computeSRTs
616

twanvl's avatar
twanvl committed
617
nonEmptySRT :: SRT -> Bool
618 619 620 621
nonEmptySRT NoSRT           = False
nonEmptySRT (SRTEntries vs) = not (isEmptyVarSet vs)
nonEmptySRT _               = True

twanvl's avatar
twanvl committed
622
pprSRT :: SRT -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
623
pprSRT (NoSRT)          = ptext (sLit "_no_srt_")
624
pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids
twanvl's avatar
twanvl committed
625
pprSRT (SRT off _ _)    = parens (ppr off <> comma <> text "*bitmap*")
626

Austin Seipp's avatar
Austin Seipp committed
627 628 629
{-
************************************************************************
*                                                                      *
630
\subsection[Stg-pretty-printing]{Pretty-printing}
Austin Seipp's avatar
Austin Seipp committed
631 632
*                                                                      *
************************************************************************
633 634 635

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
636
-}
637

638
pprGenStgBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
639
                 => GenStgBinding bndr bdee -> SDoc
640

641
pprGenStgBinding (StgNonRec bndr rhs)
642
  = hang (hsep [pprBndr LetBind bndr, equals])
643
        4 (ppr rhs <> semi)
644

645
pprGenStgBinding (StgRec pairs)
dterei's avatar
dterei committed
646 647
  = vcat $ ifPprDebug (ptext $ sLit "{- StgRec (begin) -}") :
           map (ppr_bind) pairs ++ [ifPprDebug $ ptext $ sLit "{- StgRec (end) -}"]
648
  where
649
    ppr_bind (bndr, expr)
650
      = hang (hsep [pprBndr LetBind bndr, equals])
651
             4 (ppr expr <> semi)
652

dterei's avatar
dterei committed
653
pprStgBinding :: StgBinding -> SDoc
654
pprStgBinding  bind  = pprGenStgBinding bind
sof's avatar
sof committed
655

656
pprStgBindings :: [StgBinding] -> SDoc
657 658
pprStgBindings binds = vcat (map pprGenStgBinding binds)

659 660
instance (Outputable bdee) => Outputable (GenStgArg bdee) where
    ppr = pprStgArg
661

662
instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
663
                => Outputable (GenStgBinding bndr bdee) where
sof's avatar
sof committed
664
    ppr = pprGenStgBinding
665

666
instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
667
                => Outputable (GenStgExpr bndr bdee) where
668 669
    ppr = pprStgExpr

670
instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
671
                => Outputable (GenStgRhs bndr bdee) where
672
    ppr rhs = pprStgRhs rhs
673

674 675
pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
pprStgArg (StgVarArg var) = ppr var
676
pprStgArg (StgLitArg con) = ppr con
677

678
pprStgExpr :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
679
           => GenStgExpr bndr bdee -> SDoc
680
-- special case
681
pprStgExpr (StgLit lit)     = ppr lit
682 683

-- general case
684
pprStgExpr (StgApp func args)
dterei's avatar
dterei committed
685
  = hang (ppr func) 4 (sep (map (ppr) args))
686

687
pprStgExpr (StgConApp con args)
688
  = hsep [ ppr con, brackets (interppSP args)]
689

690 691
pprStgExpr (StgOpApp op args _)
  = hsep [ pprStgOp op, brackets (interppSP args)]
692

693
pprStgExpr (StgLam bndrs body)
694 695
  = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) bndrs)
            <+> ptext (sLit "->"),
dterei's avatar
dterei committed
696
         pprStgExpr body ]
697
  where ppr_list = brackets . fsep . punctuate comma
698 699

-- special case: let v = <very specific thing>
dterei's avatar
dterei committed
700 701 702 703
--               in
--               let ...
--               in
--               ...
704 705 706
--
-- Very special!  Suspicious! (SLPJ)

707 708
{-
pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
dterei's avatar
dterei committed
709
                        expr@(StgLet _ _))
sof's avatar
sof committed
710
  = ($$)
Ian Lynagh's avatar
Ian Lynagh committed
711
      (hang (hcat [ptext (sLit "let { "), ppr bndr, ptext (sLit " = "),
dterei's avatar
dterei committed
712 713 714 715 716 717
                          ppr cc,
                          pp_binder_info bi,
                          ptext (sLit " ["), ifPprDebug (interppSP free_vars), ptext (sLit "] \\"),
                          ppr upd_flag, ptext (sLit " ["),
                          interppSP args, char ']'])
            8 (sep [hsep [ppr rhs, ptext (sLit "} in")]]))
718
      (ppr expr)
719
-}
720 721 722

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

723
pprStgExpr (StgLet bind expr@(StgLet _ _))
sof's avatar
sof committed
724
  = ($$)
Ian Lynagh's avatar
Ian Lynagh committed
725
      (sep [hang (ptext (sLit "let {"))
dterei's avatar
dterei committed
726
                2 (hsep [pprGenStgBinding bind, ptext (sLit "} in")])])
727
      (ppr expr)
728 729

-- general case
730
pprStgExpr (StgLet bind expr)
Ian Lynagh's avatar
Ian Lynagh committed
731
  = sep [hang (ptext (sLit "let {")) 2 (pprGenStgBinding bind),
dterei's avatar
dterei committed
732
           hang (ptext (sLit "} in ")) 2 (ppr expr)]
733

734
pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr)
Ian Lynagh's avatar
Ian Lynagh committed
735
  = sep [hang (ptext (sLit "let-no-escape {"))
dterei's avatar
dterei committed
736
                2 (pprGenStgBinding bind),
737 738
           hang (ptext (sLit "} in ") <>
                   ifPprDebug (
dterei's avatar
dterei committed
739 740 741
                    nest 4 (
                      hcat [ptext  (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole),
                             ptext (sLit "]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
742
                             char ']'])))
dterei's avatar
dterei committed
743
                2 (ppr expr)]
744

745 746 747 748 749 750
pprStgExpr (StgSCC cc tick push expr)
  = sep [ hsep [scc, ppr cc], pprStgExpr expr ]
  where
    scc | tick && push = ptext (sLit "_scc_")
        | tick         = ptext (sLit "_tick_")
        | otherwise    = ptext (sLit "_push_")
751

andy@galois.com's avatar
andy@galois.com committed
752
pprStgExpr (StgTick m n expr)
Ian Lynagh's avatar
Ian Lynagh committed
753
  = sep [ hsep [ptext (sLit "_tick_"),  pprModule m,text (show n)],
dterei's avatar
dterei committed
754
          pprStgExpr expr ]
andy@galois.com's avatar
andy@galois.com committed
755

756
pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts)
Ian Lynagh's avatar
Ian Lynagh committed
757
  = sep [sep [ptext (sLit "case"),
dterei's avatar
dterei committed
758 759
           nest 4 (hsep [pprStgExpr expr,
             ifPprDebug (dcolon <+> ppr alt_type)]),
760
           ptext (sLit "of"), pprBndr CaseBind bndr, char '{'],
dterei's avatar
dterei committed
761 762 763 764 765 766 767 768
           ifPprDebug (
           nest 4 (
             hcat [ptext  (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole),
                    ptext (sLit "]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
                    ptext (sLit "]; "),
                    pprMaybeSRT srt])),
           nest 2 (vcat (map pprStgAlt alts)),
           char '}']
769

770
pprStgAlt :: (OutputableBndr bndr, Outputable occ, Ord occ)
twanvl's avatar
twanvl committed
771 772
          => GenStgAlt bndr occ -> SDoc
pprStgAlt (con, params, _use_mask, expr)
773
  = hang (hsep [ppr con, sep (map (pprBndr CaseBind) params), ptext (sLit "->")])
dterei's avatar
dterei committed
774
         4 (ppr expr <> semi)
775

twanvl's avatar
twanvl committed
776
pprStgOp :: StgOp -> SDoc
777
pprStgOp (StgPrimOp  op)   = ppr op
778
pprStgOp (StgPrimCallOp op)= ppr op
779
pprStgOp (StgFCallOp op _) = ppr op
780 781

instance Outputable AltType where
dterei's avatar
dterei committed
782
  ppr PolyAlt        = ptext (sLit "Polymorphic")
783
  ppr (UbxTupAlt n)  = ptext (sLit "UbxTup") <+> ppr n
Ian Lynagh's avatar
Ian Lynagh committed
784 785
  ppr (AlgAlt tc)    = ptext (sLit "Alg")    <+> ppr tc
  ppr (PrimAlt tc)   = ptext (sLit "Prim")   <+> ppr tc
786

787 788 789 790
pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
pprStgLVs lvs
  = getPprStyle $ \ sty ->
    if userStyle sty || isEmptyUniqSet lvs then
dterei's avatar
dterei committed
791
        empty
792
    else
dterei's avatar
dterei committed
793
        hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
794

795
pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
796
          => GenStgRhs bndr bdee -> SDoc
797 798

-- special case
799
pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag srt [{-no args-}] (StgApp func []))
800
  = hcat [ ppr cc,
dterei's avatar
dterei committed
801 802 803
           pp_binder_info bi,
           brackets (ifPprDebug (ppr free_var)),
           ptext (sLit " \\"), ppr upd_flag, pprMaybeSRT srt, ptext (sLit " [] "), ppr func ]
804

805
-- general case
806
pprStgRhs (StgRhsClosure cc bi free_vars upd_flag srt args body)
807
  = sdocWithDynFlags $ \dflags ->
ian@well-typed.com's avatar
ian@well-typed.com committed
808
    hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty,
dterei's avatar
dterei committed
809 810 811 812
                pp_binder_info bi,
                ifPprDebug (brackets (interppSP free_vars)),
                char '\\' <> ppr upd_flag, pprMaybeSRT srt, brackets (interppSP args)])
         4 (ppr body)
813

814
pprStgRhs (StgRhsCon cc con args)
815
  = hcat [ ppr cc,
dterei's avatar
dterei committed
816
           space, ppr con, ptext (sLit "! "), brackets (interppSP args)]
817

twanvl's avatar
twanvl committed
818
pprMaybeSRT :: SRT -> SDoc
819
pprMaybeSRT (NoSRT) = empty
Ian Lynagh's avatar
Ian Lynagh committed
820
pprMaybeSRT srt     = ptext (sLit "srt:") <> pprSRT srt