StgSyn.hs 28 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
        stripStgTicksTop,
42

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

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

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

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

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

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

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

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

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

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

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

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

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

147 148 149 150 151 152 153 154

-- | 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
155 156 157
{-
************************************************************************
*                                                                      *
158
\subsection{STG expressions}
Austin Seipp's avatar
Austin Seipp committed
159 160
*                                                                      *
************************************************************************
161

162 163
The @GenStgExpr@ data type is parameterised on binder and occurrence
info, as before.
164

Austin Seipp's avatar
Austin Seipp committed
165 166
************************************************************************
*                                                                      *
167
\subsubsection{@GenStgExpr@ application}
Austin Seipp's avatar
Austin Seipp committed
168 169
*                                                                      *
************************************************************************
170 171 172

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
173
function. (If the arguments were expressions, we would have to build
174 175 176 177
their closures first.)

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

180
type GenStgLiveVars occ = UniqSet occ
181

182 183
data GenStgExpr bndr occ
  = StgApp
dterei's avatar
dterei committed
184 185
        occ             -- function
        [GenStgArg occ] -- arguments; may be empty
186

Austin Seipp's avatar
Austin Seipp committed
187 188 189
{-
************************************************************************
*                                                                      *
190
\subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications}
Austin Seipp's avatar
Austin Seipp committed
191 192
*                                                                      *
************************************************************************
193

dterei's avatar
dterei committed
194 195
There are a specialised forms of application, for constructors,
primitives, and literals.
Austin Seipp's avatar
Austin Seipp committed
196 197
-}

dterei's avatar
dterei committed
198 199 200 201 202 203 204 205 206 207 208 209
  | 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
210

Austin Seipp's avatar
Austin Seipp committed
211 212 213
{-
************************************************************************
*                                                                      *
214
\subsubsection{@StgLam@}
Austin Seipp's avatar
Austin Seipp committed
215 216
*                                                                      *
************************************************************************
217

dterei's avatar
dterei committed
218 219
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
220
-}
221 222

  | StgLam
dterei's avatar
dterei committed
223 224
        [bndr]
        StgExpr    -- Body of lambda
225

Austin Seipp's avatar
Austin Seipp committed
226 227 228
{-
************************************************************************
*                                                                      *
229
\subsubsection{@GenStgExpr@: case-expressions}
Austin Seipp's avatar
Austin Seipp committed
230 231
*                                                                      *
************************************************************************
232 233

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

236
  | StgCase
dterei's avatar
dterei committed
237 238
        (GenStgExpr bndr occ)
                    -- the thing to examine
239

dterei's avatar
dterei committed
240 241 242 243
        (GenStgLiveVars occ)
                    -- Live vars of whole case expression,
                    -- plus everything that happens after the case
                    -- i.e., those which mustn't be overwritten
244

dterei's avatar
dterei committed
245 246 247 248 249 250 251
        (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
252

dterei's avatar
dterei committed
253
        bndr        -- binds the result of evaluating the scrutinee
254

dterei's avatar
dterei committed
255
        SRT         -- The SRT for the continuation
256

dterei's avatar
dterei committed
257
        AltType
258

dterei's avatar
dterei committed
259 260 261
        [GenStgAlt bndr occ]
                    -- The DEFAULT case is always *first*
                    -- if it is there at all
262

Austin Seipp's avatar
Austin Seipp committed
263 264 265
{-
************************************************************************
*                                                                      *
dterei's avatar
dterei committed
266
\subsubsection{@GenStgExpr@: @let(rec)@-expressions}
Austin Seipp's avatar
Austin Seipp committed
267 268
*                                                                      *
************************************************************************
269 270 271 272 273 274

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
275
let-closure x = [free-vars] [args] expr
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 306 307 308 309 310 311 312 313 314
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
315 316
All the stuff on the RHS must be fully evaluated.
No function calls either!
317 318 319 320 321

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

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

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

\item
We may eventually want:
\begin{verbatim}
349
let-literal x = Literal
350 351 352 353 354
in e
\end{verbatim}
\end{enumerate}

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

357
  | StgLet
dterei's avatar
dterei committed
358 359
        (GenStgBinding bndr occ)    -- right hand sides (see below)
        (GenStgExpr bndr occ)       -- body
360

dterei's avatar
dterei committed
361 362 363
  | StgLetNoEscape                  -- remember: ``advanced stuff''
        (GenStgLiveVars occ)        -- Live in the whole let-expression
                                    -- Mustn't overwrite these stack slots
dterei's avatar
dterei committed
364
                                    -- _Doesn't_ include binders of the let(rec).
365

dterei's avatar
dterei committed
366 367 368
        (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
369
                                    -- _Does_ include binders of the let(rec) if recursive.
370

dterei's avatar
dterei committed
371 372
        (GenStgBinding bndr occ)    -- right hand sides (see below)
        (GenStgExpr bndr occ)       -- body
373

Austin Seipp's avatar
Austin Seipp committed
374
{-
375 376 377 378 379
%************************************************************************
%*                                                                      *
\subsubsection{@GenStgExpr@: @hpc@, @scc@ and other debug annotations}
%*                                                                      *
%************************************************************************
andy@galois.com's avatar
andy@galois.com committed
380

Edward Z. Yang's avatar
Edward Z. Yang committed
381
Finally for @hpc@ expressions we introduce a new STG construct.
Austin Seipp's avatar
Austin Seipp committed
382
-}
andy@galois.com's avatar
andy@galois.com committed
383 384

  | StgTick
385 386
    (Tickish bndr)
    (GenStgExpr bndr occ)       -- sub expression
dterei's avatar
dterei committed
387 388

-- END of GenStgExpr
389

Austin Seipp's avatar
Austin Seipp committed
390 391 392
{-
************************************************************************
*                                                                      *
393
\subsection{STG right-hand sides}
Austin Seipp's avatar
Austin Seipp committed
394 395
*                                                                      *
************************************************************************
396 397 398

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

401
data GenStgRhs bndr occ
402
  = StgRhsClosure
dterei's avatar
dterei committed
403 404 405 406 407 408 409 410 411
        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
412 413

{-
414 415 416 417 418 419 420 421 422 423 424 425 426
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
427 428
-}

429
  | StgRhsCon
dterei's avatar
dterei committed
430 431 432 433 434 435 436
        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
437

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

twanvl's avatar
twanvl committed
454
stgArgHasCafRefs :: GenStgArg Id -> Bool
455 456
stgArgHasCafRefs (StgVarArg id) = mayHaveCafRefs (idCafInfo id)
stgArgHasCafRefs _ = False
457

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

460
data StgBinderInfo
461
  = NoStgBinderInfo
dterei's avatar
dterei committed
462 463 464 465
  | 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
466

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

472 473 474
satCallsOnly :: StgBinderInfo -> Bool
satCallsOnly SatCallsOnly    = True
satCallsOnly NoStgBinderInfo = False
475 476

combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
477
combineStgBinderInfo SatCallsOnly SatCallsOnly = SatCallsOnly
twanvl's avatar
twanvl committed
478
combineStgBinderInfo _            _            = NoStgBinderInfo
479

480
--------------
twanvl's avatar
twanvl committed
481
pp_binder_info :: StgBinderInfo -> SDoc
482
pp_binder_info NoStgBinderInfo = empty
Ian Lynagh's avatar
Ian Lynagh committed
483
pp_binder_info SatCallsOnly    = ptext (sLit "sat-only")
484

Austin Seipp's avatar
Austin Seipp committed
485 486 487
{-
************************************************************************
*                                                                      *
488
\subsection[Stg-case-alternatives]{STG case alternatives}
Austin Seipp's avatar
Austin Seipp committed
489 490
*                                                                      *
************************************************************************
491

492
Very like in @CoreSyntax@ (except no type-world stuff).
493

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

504
type GenStgAlt bndr occ
dterei's avatar
dterei committed
505 506 507 508 509 510 511
  = (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.
512 513

data AltType
dterei's avatar
dterei committed
514
  = PolyAlt             -- Polymorphic (a type variable)
515
  | UbxTupAlt Int       -- Unboxed tuple of this arity
dterei's avatar
dterei committed
516 517
  | AlgAlt    TyCon     -- Algebraic data type; the AltCons will be DataAlts
  | PrimAlt   TyCon     -- Primitive data type; the AltCons will be LitAlts
518

Austin Seipp's avatar
Austin Seipp committed
519 520 521
{-
************************************************************************
*                                                                      *
522
\subsection[Stg]{The Plain STG parameterisation}
Austin Seipp's avatar
Austin Seipp committed
523 524
*                                                                      *
************************************************************************
525 526

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

dterei's avatar
dterei committed
529 530 531 532 533 534
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
535

Austin Seipp's avatar
Austin Seipp committed
536 537 538
{-
************************************************************************
*                                                                      *
539
\subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
Austin Seipp's avatar
Austin Seipp committed
540 541
*                                                                      *
************************************************************************
542

543
This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
544

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

552
data UpdateFlag = ReEntrant | Updatable | SingleEntry
553

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

twanvl's avatar
twanvl committed
560
isUpdatable :: UpdateFlag -> Bool
561 562 563 564
isUpdatable ReEntrant   = False
isUpdatable SingleEntry = False
isUpdatable Updatable   = True

Austin Seipp's avatar
Austin Seipp committed
565 566 567
{-
************************************************************************
*                                                                      *
568
\subsubsection{StgOp}
Austin Seipp's avatar
Austin Seipp committed
569 570
*                                                                      *
************************************************************************
571 572 573 574

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
575
-}
576

dterei's avatar
dterei committed
577 578
data StgOp
  = StgPrimOp  PrimOp
579

dterei's avatar
dterei committed
580
  | StgPrimCallOp PrimCall
581

dterei's avatar
dterei committed
582 583 584 585
  | 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
586

Austin Seipp's avatar
Austin Seipp committed
587 588 589
{-
************************************************************************
*                                                                      *
590
\subsubsection[Static Reference Tables]{@SRT@}
Austin Seipp's avatar
Austin Seipp committed
591 592
*                                                                      *
************************************************************************
593

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

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

dterei's avatar
dterei committed
602 603 604 605 606 607
data SRT
  = NoSRT
  | SRTEntries IdSet
        -- generated by CoreToStg
  | SRT !Int{-offset-} !Int{-length-} !Bitmap{-bitmap-}
        -- generated by computeSRTs
608

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

twanvl's avatar
twanvl committed
614
pprSRT :: SRT -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
615
pprSRT (NoSRT)          = ptext (sLit "_no_srt_")
616
pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids
twanvl's avatar
twanvl committed
617
pprSRT (SRT off _ _)    = parens (ppr off <> comma <> text "*bitmap*")
618

Austin Seipp's avatar
Austin Seipp committed
619 620 621
{-
************************************************************************
*                                                                      *
622
\subsection[Stg-pretty-printing]{Pretty-printing}
Austin Seipp's avatar
Austin Seipp committed
623 624
*                                                                      *
************************************************************************
625 626 627

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
628
-}
629

630
pprGenStgBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
631
                 => GenStgBinding bndr bdee -> SDoc
632

633
pprGenStgBinding (StgNonRec bndr rhs)
634
  = hang (hsep [pprBndr LetBind bndr, equals])
635
        4 (ppr rhs <> semi)
636

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

dterei's avatar
dterei committed
645
pprStgBinding :: StgBinding -> SDoc
646
pprStgBinding  bind  = pprGenStgBinding bind
sof's avatar
sof committed
647

648
pprStgBindings :: [StgBinding] -> SDoc
649 650
pprStgBindings binds = vcat (map pprGenStgBinding binds)

651 652
instance (Outputable bdee) => Outputable (GenStgArg bdee) where
    ppr = pprStgArg
653

654
instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
655
                => Outputable (GenStgBinding bndr bdee) where
sof's avatar
sof committed
656
    ppr = pprGenStgBinding
657

658
instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
659
                => Outputable (GenStgExpr bndr bdee) where
660 661
    ppr = pprStgExpr

662
instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
663
                => Outputable (GenStgRhs bndr bdee) where
664
    ppr rhs = pprStgRhs rhs
665

666 667
pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
pprStgArg (StgVarArg var) = ppr var
668
pprStgArg (StgLitArg con) = ppr con
669

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

-- general case
676
pprStgExpr (StgApp func args)
dterei's avatar
dterei committed
677
  = hang (ppr func) 4 (sep (map (ppr) args))
678

679
pprStgExpr (StgConApp con args)
680
  = hsep [ ppr con, brackets (interppSP args)]
681

682 683
pprStgExpr (StgOpApp op args _)
  = hsep [ pprStgOp op, brackets (interppSP args)]
684

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

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

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

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

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

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

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

737 738 739 740 741
pprStgExpr (StgTick tickish expr)
  = sdocWithDynFlags $ \dflags ->
    if gopt Opt_PprShowTicks dflags
    then sep [ ppr tickish, pprStgExpr expr ]
    else pprStgExpr expr
742

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

744
pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts)
Ian Lynagh's avatar
Ian Lynagh committed
745
  = sep [sep [ptext (sLit "case"),
dterei's avatar
dterei committed
746 747
           nest 4 (hsep [pprStgExpr expr,
             ifPprDebug (dcolon <+> ppr alt_type)]),
748
           ptext (sLit "of"), pprBndr CaseBind bndr, char '{'],
dterei's avatar
dterei committed
749 750 751 752 753 754 755 756
           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 '}']
757

758
pprStgAlt :: (OutputableBndr bndr, Outputable occ, Ord occ)
twanvl's avatar
twanvl committed
759 760
          => GenStgAlt bndr occ -> SDoc
pprStgAlt (con, params, _use_mask, expr)
761
  = hang (hsep [ppr con, sep (map (pprBndr CaseBind) params), ptext (sLit "->")])
dterei's avatar
dterei committed
762
         4 (ppr expr <> semi)
763

twanvl's avatar
twanvl committed
764
pprStgOp :: StgOp -> SDoc
765
pprStgOp (StgPrimOp  op)   = ppr op
766
pprStgOp (StgPrimCallOp op)= ppr op
767
pprStgOp (StgFCallOp op _) = ppr op
768 769

instance Outputable AltType where
dterei's avatar
dterei committed
770
  ppr PolyAlt        = ptext (sLit "Polymorphic")
771
  ppr (UbxTupAlt n)  = ptext (sLit "UbxTup") <+> ppr n
Ian Lynagh's avatar
Ian Lynagh committed
772 773
  ppr (AlgAlt tc)    = ptext (sLit "Alg")    <+> ppr tc
  ppr (PrimAlt tc)   = ptext (sLit "Prim")   <+> ppr tc
774

775 776 777 778
pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
pprStgLVs lvs
  = getPprStyle $ \ sty ->
    if userStyle sty || isEmptyUniqSet lvs then
dterei's avatar
dterei committed
779
        empty
780
    else
dterei's avatar
dterei committed
781
        hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
782

783
pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
784
          => GenStgRhs bndr bdee -> SDoc
785 786

-- special case
787
pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag srt [{-no args-}] (StgApp func []))
788
  = hcat [ ppr cc,
dterei's avatar
dterei committed
789 790 791
           pp_binder_info bi,
           brackets (ifPprDebug (ppr free_var)),
           ptext (sLit " \\"), ppr upd_flag, pprMaybeSRT srt, ptext (sLit " [] "), ppr func ]
792

793
-- general case
794
pprStgRhs (StgRhsClosure cc bi free_vars upd_flag srt args body)
795
  = sdocWithDynFlags $ \dflags ->
ian@well-typed.com's avatar
ian@well-typed.com committed
796
    hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty,
dterei's avatar
dterei committed
797 798 799 800
                pp_binder_info bi,
                ifPprDebug (brackets (interppSP free_vars)),
                char '\\' <> ppr upd_flag, pprMaybeSRT srt, brackets (interppSP args)])
         4 (ppr body)
801

802
pprStgRhs (StgRhsCon cc con args)
803
  = hcat [ ppr cc,
dterei's avatar
dterei committed
804
           space, ppr con, ptext (sLit "! "), brackets (interppSP args)]
805

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