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

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
data SRT
  = NoSRT
  | SRTEntries IdSet
        -- generated by CoreToStg
606

twanvl's avatar
twanvl committed
607
nonEmptySRT :: SRT -> Bool
608
609
610
nonEmptySRT NoSRT           = False
nonEmptySRT (SRTEntries vs) = not (isEmptyVarSet vs)

twanvl's avatar
twanvl committed
611
pprSRT :: SRT -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
612
pprSRT (NoSRT)          = ptext (sLit "_no_srt_")
613
pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids
614

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)
dterei's avatar
dterei committed
634
635
  = vcat $ ifPprDebug (ptext $ sLit "{- StgRec (begin) -}") :
           map (ppr_bind) pairs ++ [ifPprDebug $ ptext $ sLit "{- 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
683
  = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) bndrs)
            <+> ptext (sLit "->"),
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
  = ($$)
Ian Lynagh's avatar
Ian Lynagh committed
699
      (hang (hcat [ptext (sLit "let { "), ppr bndr, ptext (sLit " = "),
dterei's avatar
dterei committed
700
701
702
703
704
705
                          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")]]))
706
      (ppr expr)
707
-}
708
709
710

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

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

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

722
pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr)
Ian Lynagh's avatar
Ian Lynagh committed
723
  = sep [hang (ptext (sLit "let-no-escape {"))
dterei's avatar
dterei committed
724
                2 (pprGenStgBinding bind),
725
726
           hang (ptext (sLit "} in ") <>
                   ifPprDebug (
dterei's avatar
dterei committed
727
728
729
                    nest 4 (
                      hcat [ptext  (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole),
                             ptext (sLit "]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
730
                             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)
Ian Lynagh's avatar
Ian Lynagh committed
741
  = sep [sep [ptext (sLit "case"),
dterei's avatar
dterei committed
742
743
           nest 4 (hsep [pprStgExpr expr,
             ifPprDebug (dcolon <+> ppr alt_type)]),
744
           ptext (sLit "of"), pprBndr CaseBind bndr, char '{'],
dterei's avatar
dterei committed
745
746
747
748
749
750
751
752
           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 '}']
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), ptext (sLit "->")])
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
dterei's avatar
dterei committed
766
  ppr PolyAlt        = ptext (sLit "Polymorphic")
767
  ppr (UbxTupAlt n)  = ptext (sLit "UbxTup") <+> ppr n
Ian Lynagh's avatar
Ian Lynagh committed
768
769
  ppr (AlgAlt tc)    = ptext (sLit "Alg")    <+> ppr tc
  ppr (PrimAlt tc)   = ptext (sLit "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
787
           pp_binder_info bi,
           brackets (ifPprDebug (ppr free_var)),
           ptext (sLit " \\"), 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
795
796
                pp_binder_info bi,
                ifPprDebug (brackets (interppSP free_vars)),
                char '\\' <> ppr upd_flag, pprMaybeSRT srt, brackets (interppSP args)])
         4 (ppr body)
797

798
pprStgRhs (StgRhsCon cc con args)
799
  = hcat [ ppr cc,
dterei's avatar
dterei committed
800
           space, ppr con, ptext (sLit "! "), brackets (interppSP args)]
801

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