StgSyn.lhs 28.9 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 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.
10 11

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
12

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

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

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

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

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

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

dterei's avatar
dterei committed
33 34
        -- SRTs
        SRT(..),
35

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

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

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

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

%************************************************************************
dterei's avatar
dterei committed
74
%*                                                                      *
75
\subsection{@GenStgBinding@}
dterei's avatar
dterei committed
76
%*                                                                      *
77 78
%************************************************************************

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

84 85
There is one SRT for each group of bindings.

86
\begin{code}
87
data GenStgBinding bndr occ
dterei's avatar
dterei committed
88 89
  = StgNonRec bndr (GenStgRhs bndr occ)
  | StgRec    [(bndr, GenStgRhs bndr occ)]
90 91 92
\end{code}

%************************************************************************
dterei's avatar
dterei committed
93
%*                                                                      *
94
\subsection{@GenStgArg@}
dterei's avatar
dterei committed
95
%*                                                                      *
96 97 98
%************************************************************************

\begin{code}
99
data GenStgArg occ
dterei's avatar
dterei committed
100 101
  = StgVarArg  occ
  | StgLitArg  Literal
102

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

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

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

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

%************************************************************************
dterei's avatar
dterei committed
147
%*                                                                      *
148
\subsection{STG expressions}
dterei's avatar
dterei committed
149
%*                                                                      *
150 151
%************************************************************************

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

%************************************************************************
dterei's avatar
dterei committed
156
%*                                                                      *
157
\subsubsection{@GenStgExpr@ application}
dterei's avatar
dterei committed
158
%*                                                                      *
159 160 161 162
%************************************************************************

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

There is no constructor for a lone variable; it would appear as
@StgApp var [] _@.
\begin{code}
169
type GenStgLiveVars occ = UniqSet occ
170

171 172
data GenStgExpr bndr occ
  = StgApp
dterei's avatar
dterei committed
173 174
        occ             -- function
        [GenStgArg occ] -- arguments; may be empty
175 176 177
\end{code}

%************************************************************************
dterei's avatar
dterei committed
178
%*                                                                      *
179
\subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications}
dterei's avatar
dterei committed
180
%*                                                                      *
181 182
%************************************************************************

dterei's avatar
dterei committed
183 184
There are a specialised forms of application, for constructors,
primitives, and literals.
185
\begin{code}
dterei's avatar
dterei committed
186 187 188 189 190 191 192 193 194 195 196 197
  | 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
198 199
\end{code}

200
%************************************************************************
dterei's avatar
dterei committed
201
%*                                                                      *
202
\subsubsection{@StgLam@}
dterei's avatar
dterei committed
203
%*                                                                      *
204 205
%************************************************************************

dterei's avatar
dterei committed
206 207
StgLam is used *only* during CoreToStg's work. Before CoreToStg has
finished it encodes (\x -> e) as (let f = \x -> e in f)
208 209 210

\begin{code}
  | StgLam
dterei's avatar
dterei committed
211 212
        [bndr]
        StgExpr    -- Body of lambda
213 214 215
\end{code}


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

This has the same boxed/unboxed business as Core case expressions.
\begin{code}
  | StgCase
dterei's avatar
dterei committed
225 226
        (GenStgExpr bndr occ)
                    -- the thing to examine
227

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

dterei's avatar
dterei committed
233 234 235 236 237 238 239
        (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
240

dterei's avatar
dterei committed
241
        bndr        -- binds the result of evaluating the scrutinee
242

dterei's avatar
dterei committed
243
        SRT         -- The SRT for the continuation
244

dterei's avatar
dterei committed
245
        AltType
246

dterei's avatar
dterei committed
247 248 249
        [GenStgAlt bndr occ]
                    -- The DEFAULT case is always *first*
                    -- if it is there at all
250 251 252
\end{code}

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

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

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

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

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

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

And so the code for let(rec)-things:
\begin{code}
  | StgLet
dterei's avatar
dterei committed
345 346
        (GenStgBinding bndr occ)    -- right hand sides (see below)
        (GenStgExpr bndr occ)       -- body
347

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

dterei's avatar
dterei committed
353 354 355
        (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
356
                                    -- _Does_ include binders of the let(rec) if recursive.
357

dterei's avatar
dterei committed
358 359
        (GenStgBinding bndr occ)    -- right hand sides (see below)
        (GenStgExpr bndr occ)       -- body
360 361 362
\end{code}

%************************************************************************
dterei's avatar
dterei committed
363
%*                                                                      *
364
\subsubsection{@GenStgExpr@: @scc@ expressions}
dterei's avatar
dterei committed
365
%*                                                                      *
366 367
%************************************************************************

dterei's avatar
dterei committed
368
For @scc@ expressions we introduce a new STG construct.
369 370 371

\begin{code}
  | StgSCC
dterei's avatar
dterei committed
372 373 374 375
        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
376 377 378
\end{code}

%************************************************************************
dterei's avatar
dterei committed
379
%*                                                                      *
andy@galois.com's avatar
andy@galois.com committed
380
\subsubsection{@GenStgExpr@: @hpc@ expressions}
dterei's avatar
dterei committed
381
%*                                                                      *
andy@galois.com's avatar
andy@galois.com committed
382 383
%************************************************************************

Edward Z. Yang's avatar
Edward Z. Yang committed
384
Finally for @hpc@ expressions we introduce a new STG construct.
andy@galois.com's avatar
andy@galois.com committed
385 386 387

\begin{code}
  | StgTick
dterei's avatar
dterei committed
388 389 390 391 392
        Module                 -- the module of the source of this tick
        Int                    -- tick number
        (GenStgExpr bndr occ)  -- sub expression

-- END of GenStgExpr
393 394 395
\end{code}

%************************************************************************
dterei's avatar
dterei committed
396
%*                                                                      *
397
\subsection{STG right-hand sides}
dterei's avatar
dterei committed
398
%*                                                                      *
399 400 401 402 403
%************************************************************************

Here's the rest of the interesting stuff for @StgLet@s; the first
flavour is for closures:
\begin{code}
404
data GenStgRhs bndr occ
405
  = StgRhsClosure
dterei's avatar
dterei committed
406 407 408 409 410 411 412 413 414
        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
415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430
\end{code}
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):
\begin{code}
  | StgRhsCon
dterei's avatar
dterei committed
431 432 433 434 435 436 437
        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
438

439
stgRhsArity :: StgRhs -> Int
dterei's avatar
dterei committed
440
stgRhsArity (StgRhsClosure _ _ _ _ _ bndrs _)
441 442
  = ASSERT( all isId bndrs ) length bndrs
  -- The arity never includes type parameters, but they should have gone by now
443 444 445 446 447 448
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
449
rhsHasCafRefs :: GenStgRhs bndr Id -> Bool
dterei's avatar
dterei committed
450
rhsHasCafRefs (StgRhsClosure _ _ _ upd srt _ _)
451 452 453 454
  = isUpdatable upd || nonEmptySRT srt
rhsHasCafRefs (StgRhsCon _ _ args)
  = any stgArgHasCafRefs args

twanvl's avatar
twanvl committed
455
stgArgHasCafRefs :: GenStgArg Id -> Bool
456 457
stgArgHasCafRefs (StgVarArg id) = mayHaveCafRefs (idCafInfo id)
stgArgHasCafRefs _ = False
458 459
\end{code}

460 461
Here's the @StgBinderInfo@ type, and its combining op:
\begin{code}
462
data StgBinderInfo
463
  = NoStgBinderInfo
dterei's avatar
dterei committed
464 465 466 467
  | 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
468

twanvl's avatar
twanvl committed
469
noBinderInfo, stgUnsatOcc, stgSatOcc :: StgBinderInfo
470 471 472
noBinderInfo = NoStgBinderInfo
stgUnsatOcc  = NoStgBinderInfo
stgSatOcc    = SatCallsOnly
473

474 475 476
satCallsOnly :: StgBinderInfo -> Bool
satCallsOnly SatCallsOnly    = True
satCallsOnly NoStgBinderInfo = False
477 478

combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
479
combineStgBinderInfo SatCallsOnly SatCallsOnly = SatCallsOnly
twanvl's avatar
twanvl committed
480
combineStgBinderInfo _            _            = NoStgBinderInfo
481

482
--------------
twanvl's avatar
twanvl committed
483
pp_binder_info :: StgBinderInfo -> SDoc
484
pp_binder_info NoStgBinderInfo = empty
Ian Lynagh's avatar
Ian Lynagh committed
485
pp_binder_info SatCallsOnly    = ptext (sLit "sat-only")
486 487 488
\end{code}

%************************************************************************
dterei's avatar
dterei committed
489
%*                                                                      *
490
\subsection[Stg-case-alternatives]{STG case alternatives}
dterei's avatar
dterei committed
491
%*                                                                      *
492 493
%************************************************************************

494
Very like in @CoreSyntax@ (except no type-world stuff).
495

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

505
\begin{code}
506
type GenStgAlt bndr occ
dterei's avatar
dterei committed
507 508 509 510 511 512 513
  = (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.
514 515

data AltType
dterei's avatar
dterei committed
516
  = PolyAlt             -- Polymorphic (a type variable)
517
  | UbxTupAlt Int       -- Unboxed tuple of this arity
dterei's avatar
dterei committed
518 519
  | AlgAlt    TyCon     -- Algebraic data type; the AltCons will be DataAlts
  | PrimAlt   TyCon     -- Primitive data type; the AltCons will be LitAlts
520 521 522
\end{code}

%************************************************************************
dterei's avatar
dterei committed
523
%*                                                                      *
524
\subsection[Stg]{The Plain STG parameterisation}
dterei's avatar
dterei committed
525
%*                                                                      *
526 527 528 529 530
%************************************************************************

This happens to be the only one we use at the moment.

\begin{code}
dterei's avatar
dterei committed
531 532 533 534 535 536
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
537 538 539 540 541 542 543
\end{code}

%************************************************************************
%*                                                                      *
\subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
%*                                                                      *
%************************************************************************
544

545
This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
546

547
A @ReEntrant@ closure may be entered multiple times, but should not be
dterei's avatar
dterei committed
548 549
updated or blackholed. An @Updatable@ closure should be updated after
evaluation (and may be blackholed during evaluation). A @SingleEntry@
550 551 552
closure will only be entered once, and so need not be updated but may
safely be blackholed.

553 554
\begin{code}
data UpdateFlag = ReEntrant | Updatable | SingleEntry
555

556
instance Outputable UpdateFlag where
dterei's avatar
dterei committed
557 558 559 560
    ppr u = char $ case u of
                       ReEntrant   -> 'r'
                       Updatable   -> 'u'
                       SingleEntry -> 's'
561

twanvl's avatar
twanvl committed
562
isUpdatable :: UpdateFlag -> Bool
563 564 565 566 567
isUpdatable ReEntrant   = False
isUpdatable SingleEntry = False
isUpdatable Updatable   = True
\end{code}

568 569 570 571 572 573 574 575 576 577 578
%************************************************************************
%*                                                                      *
\subsubsection{StgOp}
%*                                                                      *
%************************************************************************

An StgOp allows us to group together PrimOps and ForeignCalls.
It's quite useful to move these around together, notably
in StgOpApp and COpStmt.

\begin{code}
dterei's avatar
dterei committed
579 580
data StgOp
  = StgPrimOp  PrimOp
581

dterei's avatar
dterei committed
582
  | StgPrimCallOp PrimCall
583

dterei's avatar
dterei committed
584 585 586 587
  | 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
588 589 590
\end{code}


591 592 593 594 595 596
%************************************************************************
%*                                                                      *
\subsubsection[Static Reference Tables]{@SRT@}
%*                                                                      *
%************************************************************************

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

dterei's avatar
dterei committed
601
In CoreToStg we collect the list of CafRefs at each SRT site, which is later
602 603
converted into the length and offset form by the SRT pass.

604
\begin{code}
dterei's avatar
dterei committed
605 606 607 608 609 610
data SRT
  = NoSRT
  | SRTEntries IdSet
        -- generated by CoreToStg
  | SRT !Int{-offset-} !Int{-length-} !Bitmap{-bitmap-}
        -- generated by computeSRTs
611

twanvl's avatar
twanvl committed
612
nonEmptySRT :: SRT -> Bool
613 614 615 616
nonEmptySRT NoSRT           = False
nonEmptySRT (SRTEntries vs) = not (isEmptyVarSet vs)
nonEmptySRT _               = True

twanvl's avatar
twanvl committed
617
pprSRT :: SRT -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
618
pprSRT (NoSRT)          = ptext (sLit "_no_srt_")
619
pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids
twanvl's avatar
twanvl committed
620
pprSRT (SRT off _ _)    = parens (ppr off <> comma <> text "*bitmap*")
621 622 623
\end{code}

%************************************************************************
dterei's avatar
dterei committed
624
%*                                                                      *
625
\subsection[Stg-pretty-printing]{Pretty-printing}
dterei's avatar
dterei committed
626
%*                                                                      *
627 628 629 630 631 632
%************************************************************************

Robin Popplestone asked for semi-colon separators on STG binds; here's
hoping he likes terminators instead...  Ditto for case alternatives.

\begin{code}
633
pprGenStgBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
634
                 => GenStgBinding bndr bdee -> SDoc
635

636
pprGenStgBinding (StgNonRec bndr rhs)
637
  = hang (hsep [pprBndr LetBind bndr, equals])
638
        4 (ppr rhs <> semi)
639

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

dterei's avatar
dterei committed
648
pprStgBinding :: StgBinding -> SDoc
649
pprStgBinding  bind  = pprGenStgBinding bind
sof's avatar
sof committed
650

651
pprStgBindings :: [StgBinding] -> SDoc
652 653
pprStgBindings binds = vcat (map pprGenStgBinding binds)

654 655
instance (Outputable bdee) => Outputable (GenStgArg bdee) where
    ppr = pprStgArg
656

657
instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
658
                => Outputable (GenStgBinding bndr bdee) where
sof's avatar
sof committed
659
    ppr = pprGenStgBinding
660

661
instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
662
                => Outputable (GenStgExpr bndr bdee) where
663 664
    ppr = pprStgExpr

665
instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
666
                => Outputable (GenStgRhs bndr bdee) where
667
    ppr rhs = pprStgRhs rhs
668

669 670
pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
pprStgArg (StgVarArg var) = ppr var
671
pprStgArg (StgLitArg con) = ppr con
672

673
pprStgExpr :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
674
           => GenStgExpr bndr bdee -> SDoc
675
-- special case
676
pprStgExpr (StgLit lit)     = ppr lit
677 678

-- general case
679
pprStgExpr (StgApp func args)
dterei's avatar
dterei committed
680
  = hang (ppr func) 4 (sep (map (ppr) args))
681

682
pprStgExpr (StgConApp con args)
683
  = hsep [ ppr con, brackets (interppSP args)]
684

685 686
pprStgExpr (StgOpApp op args _)
  = hsep [ pprStgOp op, brackets (interppSP args)]
687

688
pprStgExpr (StgLam bndrs body)
689 690
  = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) bndrs)
            <+> ptext (sLit "->"),
dterei's avatar
dterei committed
691
         pprStgExpr body ]
692
  where ppr_list = brackets . fsep . punctuate comma
693 694

-- special case: let v = <very specific thing>
dterei's avatar
dterei committed
695 696 697 698
--               in
--               let ...
--               in
--               ...
699 700 701
--
-- Very special!  Suspicious! (SLPJ)

702 703
{-
pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
dterei's avatar
dterei committed
704
                        expr@(StgLet _ _))
sof's avatar
sof committed
705
  = ($$)
Ian Lynagh's avatar
Ian Lynagh committed
706
      (hang (hcat [ptext (sLit "let { "), ppr bndr, ptext (sLit " = "),
dterei's avatar
dterei committed
707 708 709 710 711 712
                          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")]]))
713
      (ppr expr)
714
-}
715 716 717

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

718
pprStgExpr (StgLet bind expr@(StgLet _ _))
sof's avatar
sof committed
719
  = ($$)
Ian Lynagh's avatar
Ian Lynagh committed
720
      (sep [hang (ptext (sLit "let {"))
dterei's avatar
dterei committed
721
                2 (hsep [pprGenStgBinding bind, ptext (sLit "} in")])])
722
      (ppr expr)
723 724

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

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

740 741 742 743 744 745
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_")
746

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

751
pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts)
Ian Lynagh's avatar
Ian Lynagh committed
752
  = sep [sep [ptext (sLit "case"),
dterei's avatar
dterei committed
753 754
           nest 4 (hsep [pprStgExpr expr,
             ifPprDebug (dcolon <+> ppr alt_type)]),
755
           ptext (sLit "of"), pprBndr CaseBind bndr, char '{'],
dterei's avatar
dterei committed
756 757 758 759 760 761 762 763
           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 '}']
764

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

twanvl's avatar
twanvl committed
771
pprStgOp :: StgOp -> SDoc
772
pprStgOp (StgPrimOp  op)   = ppr op
773
pprStgOp (StgPrimCallOp op)= ppr op
774
pprStgOp (StgFCallOp op _) = ppr op
775 776

instance Outputable AltType where
dterei's avatar
dterei committed
777
  ppr PolyAlt        = ptext (sLit "Polymorphic")
778
  ppr (UbxTupAlt n)  = ptext (sLit "UbxTup") <+> ppr n
Ian Lynagh's avatar
Ian Lynagh committed
779 780
  ppr (AlgAlt tc)    = ptext (sLit "Alg")    <+> ppr tc
  ppr (PrimAlt tc)   = ptext (sLit "Prim")   <+> ppr tc
781

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

790
pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
791
          => GenStgRhs bndr bdee -> SDoc
792 793

-- special case
794
pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag srt [{-no args-}] (StgApp func []))
795
  = hcat [ ppr cc,
dterei's avatar
dterei committed
796 797 798
           pp_binder_info bi,
           brackets (ifPprDebug (ppr free_var)),
           ptext (sLit " \\"), ppr upd_flag, pprMaybeSRT srt, ptext (sLit " [] "), ppr func ]
799

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

809
pprStgRhs (StgRhsCon cc con args)
810
  = hcat [ ppr cc,
dterei's avatar
dterei committed
811
           space, ppr con, ptext (sLit "! "), brackets (interppSP args)]
812

twanvl's avatar
twanvl committed
813
pprMaybeSRT :: SRT -> SDoc
814
pprMaybeSRT (NoSRT) = empty
Ian Lynagh's avatar
Ian Lynagh committed
815
pprMaybeSRT srt     = ptext (sLit "srt:") <> pprSRT srt
816
\end{code}
dterei's avatar
dterei committed
817