StgSyn.hs 27.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

34 35 36
        -- SRTs
        SRT(..),

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 50
import CoreSyn     ( AltCon, Tickish )
import CostCentre  ( CostCentreStack )
51
import Data.List   ( intersperse )
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
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
their closures first.)

There is no constructor for a lone variable; it would appear as
rwbarton's avatar
rwbarton committed
177
@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

rwbarton's avatar
rwbarton committed
194
There are specialised forms of application, for constructors,
dterei's avatar
dterei committed
195
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

240 241 242 243 244 245 246 247 248 249 250 251 252
        (GenStgLiveVars occ)
                    -- Live vars of whole case expression,
                    -- plus everything that happens after the case
                    -- i.e., those which mustn't be overwritten

        (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

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

255 256
        SRT         -- The SRT for the continuation

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

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

        (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
                                    -- _Does_ include binders of the let(rec) if recursive.

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
        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
408
        SRT                     -- The SRT reference
dterei's avatar
dterei committed
409 410 411
        [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
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
449 450
rhsHasCafRefs (StgRhsClosure _ _ _ upd srt _ _)
  = isUpdatable upd || nonEmptySRT srt
451 452 453
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
483
pp_binder_info SatCallsOnly    = text "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

587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614
{-
************************************************************************
*                                                                      *
\subsubsection[Static Reference Tables]{@SRT@}
*                                                                      *
************************************************************************

There is one SRT per top-level function group. Each local binding and
case expression within this binding group has a subrange of the whole
SRT, expressed as an offset and length.

In CoreToStg we collect the list of CafRefs at each SRT site, which is later
converted into the length and offset form by the SRT pass.
-}

data SRT
  = NoSRT
  | SRTEntries IdSet
        -- generated by CoreToStg

nonEmptySRT :: SRT -> Bool
nonEmptySRT NoSRT           = False
nonEmptySRT (SRTEntries vs) = not (isEmptyVarSet vs)

pprSRT :: SRT -> SDoc
pprSRT (NoSRT)          = text "_no_srt_"
pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids

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

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
624
-}
625

626
pprGenStgBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
627
                 => GenStgBinding bndr bdee -> SDoc
628

629
pprGenStgBinding (StgNonRec bndr rhs)
630
  = hang (hsep [pprBndr LetBind bndr, equals])
631
        4 (ppr rhs <> semi)
632

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

dterei's avatar
dterei committed
641
pprStgBinding :: StgBinding -> SDoc
642
pprStgBinding  bind  = pprGenStgBinding bind
sof's avatar
sof committed
643

644
pprStgBindings :: [StgBinding] -> SDoc
645
pprStgBindings binds = vcat $ intersperse blankLine (map pprGenStgBinding binds)
646

647 648
instance (Outputable bdee) => Outputable (GenStgArg bdee) where
    ppr = pprStgArg
649

650
instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
651
                => Outputable (GenStgBinding bndr bdee) where
sof's avatar
sof committed
652
    ppr = pprGenStgBinding
653

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

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

662 663
pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
pprStgArg (StgVarArg var) = ppr var
664
pprStgArg (StgLitArg con) = ppr con
665

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

-- general case
672
pprStgExpr (StgApp func args)
dterei's avatar
dterei committed
673
  = hang (ppr func) 4 (sep (map (ppr) args))
674

675
pprStgExpr (StgConApp con args)
676
  = hsep [ ppr con, brackets (interppSP args)]
677

678 679
pprStgExpr (StgOpApp op args _)
  = hsep [ pprStgOp op, brackets (interppSP args)]
680

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

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

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

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

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

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

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

733 734 735 736 737
pprStgExpr (StgTick tickish expr)
  = sdocWithDynFlags $ \dflags ->
    if gopt Opt_PprShowTicks dflags
    then sep [ ppr tickish, pprStgExpr expr ]
    else pprStgExpr expr
738

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

740
pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts)
741
  = sep [sep [text "case",
dterei's avatar
dterei committed
742 743
           nest 4 (hsep [pprStgExpr expr,
             ifPprDebug (dcolon <+> ppr alt_type)]),
744
           text "of", pprBndr CaseBind bndr, char '{'],
745 746 747 748 749 750
           ifPprDebug (
           nest 4 (
             hcat [ptext  (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole),
                    text "]; rhs lvs: [", interppSP (uniqSetToList lvs_rhss),
                    text "]; ",
                    pprMaybeSRT srt])),
dterei's avatar
dterei committed
751 752
           nest 2 (vcat (map pprStgAlt alts)),
           char '}']
753

754
pprStgAlt :: (OutputableBndr bndr, Outputable occ, Ord occ)
twanvl's avatar
twanvl committed
755 756
          => GenStgAlt bndr occ -> SDoc
pprStgAlt (con, params, _use_mask, expr)
757
  = hang (hsep [ppr con, sep (map (pprBndr CaseBind) params), text "->"])
dterei's avatar
dterei committed
758
         4 (ppr expr <> semi)
759

twanvl's avatar
twanvl committed
760
pprStgOp :: StgOp -> SDoc
761
pprStgOp (StgPrimOp  op)   = ppr op
762
pprStgOp (StgPrimCallOp op)= ppr op
763
pprStgOp (StgFCallOp op _) = ppr op
764 765

instance Outputable AltType where
766 767 768 769
  ppr PolyAlt        = text "Polymorphic"
  ppr (UbxTupAlt n)  = text "UbxTup" <+> ppr n
  ppr (AlgAlt tc)    = text "Alg"    <+> ppr tc
  ppr (PrimAlt tc)   = text "Prim"   <+> ppr tc
770

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

779
pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
dterei's avatar
dterei committed
780
          => GenStgRhs bndr bdee -> SDoc
781 782

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

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

798
pprStgRhs (StgRhsCon cc con args)
799
  = hcat [ ppr cc,
800
           space, ppr con, text "! ", brackets (interppSP args)]
801 802 803 804

pprMaybeSRT :: SRT -> SDoc
pprMaybeSRT (NoSRT) = empty
pprMaybeSRT srt     = text "srt:" <> pprSRT srt