CoreToStg.lhs 42.7 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3
%
4
\section[CoreToStg]{Converts Core to STG Syntax}
5

6
7
And, as we have the info in hand, we may convert some lets to
let-no-escapes.
8
9

\begin{code}
10
module CoreToStg ( coreToStg, coreExprToStg ) where
11

12
#include "HsVersions.h"
13

14
import CoreSyn
15
16
import CoreUtils        ( exprType, findDefault )
import CoreArity        ( manifestArity )
17
import StgSyn
18

19
import Type
20
import TyCon
21
import Id
22
import Var              ( Var )
23
24
import IdInfo
import DataCon
25
import CostCentre       ( noCCS )
26
import VarSet
27
import VarEnv
28
29
30
import Maybes           ( maybeToBool )
import Name             ( getOccName, isExternalName, nameOccName )
import OccName          ( occNameString, occNameFS )
31
import BasicTypes       ( Arity )
32
import Module
33
import Outputable
twanvl's avatar
twanvl committed
34
import MonadUtils
35
import FastString
Ian Lynagh's avatar
Ian Lynagh committed
36
import Util
37
import ForeignCall
38
import PrimOp           ( PrimCall(..) )
39
40
\end{code}

41
%************************************************************************
42
%*                                                                      *
43
\subsection[live-vs-free-doc]{Documentation}
44
%*                                                                      *
45
46
%************************************************************************

47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
(There is other relevant documentation in codeGen/CgLetNoEscape.)

The actual Stg datatype is decorated with {\em live variable}
information, as well as {\em free variable} information.  The two are
{\em not} the same.  Liveness is an operational property rather than a
semantic one.  A variable is live at a particular execution point if
it can be referred to {\em directly} again.  In particular, a dead
variable's stack slot (if it has one):
\begin{enumerate}
\item
should be stubbed to avoid space leaks, and
\item
may be reused for something else.
\end{enumerate}

There ought to be a better way to say this.  Here are some examples:
\begin{verbatim}
64
65
66
        let v = [q] \[x] -> e
        in
        ...v...  (but no q's)
67
68
\end{verbatim}

69
Just after the `in', v is live, but q is dead.  If the whole of that
70
71
let expression was enclosed in a case expression, thus:
\begin{verbatim}
72
73
        case (let v = [q] \[x] -> e in ...v...) of
                alts[...q...]
74
75
76
77
78
79
\end{verbatim}
(ie @alts@ mention @q@), then @q@ is live even after the `in'; because
we'll return later to the @alts@ and need it.

Let-no-escapes make this a bit more interesting:
\begin{verbatim}
80
81
82
        let-no-escape v = [q] \ [x] -> e
        in
        ...v...
83
84
85
86
87
88
\end{verbatim}
Here, @q@ is still live at the `in', because @v@ is represented not by
a closure but by the current stack state.  In other words, if @v@ is
live then so is @q@.  Furthermore, if @e@ mentions an enclosing
let-no-escaped variable, then {\em its} free variables are also live
if @v@ is.
89

90
%************************************************************************
91
%*                                                                      *
92
\subsection[caf-info]{Collecting live CAF info}
93
%*                                                                      *
94
95
%************************************************************************

96
97
In this pass we also collect information on which CAFs are live for
constructing SRTs (see SRT.lhs).
98
99
100

A top-level Id has CafInfo, which is

101
102
103
        - MayHaveCafRefs, if it may refer indirectly to
          one or more CAFs, or
        - NoCafRefs if it definitely doesn't
104

105
The CafInfo has already been calculated during the CoreTidy pass.
106
107
108
109
110
111
112
113
114
115

During CoreToStg, we then pin onto each binding and case expression, a
list of Ids which represents the "live" CAFs at that point.  The meaning
of "live" here is the same as for live variables, see above (which is
why it's convenient to collect CAF information here rather than elsewhere).

The later SRT pass takes these lists of Ids and uses them to construct
the actual nested SRTs, and replaces the lists of Ids with (offset,length)
pairs.

116
117
118
119
120

Interaction of let-no-escape with SRTs   [Sept 01]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider

121
122
123
        let-no-escape x = ...caf1...caf2...
        in
        ...x...x...x...
124

125
where caf1,caf2 are CAFs.  Since x doesn't have a closure, we
126
127
128
129
130
131
132
133
134
build SRTs just as if x's defn was inlined at each call site, and
that means that x's CAF refs get duplicated in the overall SRT.

This is unlike ordinary lets, in which the CAF refs are not duplicated.

We could fix this loss of (static) sharing by making a sort of pseudo-closure
for x, solely to put in the SRTs lower down.


135
%************************************************************************
136
%*                                                                      *
137
\subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
138
%*                                                                      *
139
140
141
%************************************************************************

\begin{code}
Simon Marlow's avatar
Simon Marlow committed
142
143
coreToStg :: PackageId -> [CoreBind] -> IO [StgBinding]
coreToStg this_pkg pgm
144
  = return pgm'
Simon Marlow's avatar
Simon Marlow committed
145
  where (_, _, pgm') = coreTopBindsToStg this_pkg emptyVarEnv pgm
146
147

coreExprToStg :: CoreExpr -> StgExpr
148
coreExprToStg expr
149
150
151
152
  = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)


coreTopBindsToStg
Simon Marlow's avatar
Simon Marlow committed
153
    :: PackageId
154
    -> IdEnv HowBound           -- environment for the bindings
155
156
157
    -> [CoreBind]
    -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])

Ian Lynagh's avatar
Ian Lynagh committed
158
coreTopBindsToStg _        env [] = (env, emptyFVInfo, [])
Simon Marlow's avatar
Simon Marlow committed
159
coreTopBindsToStg this_pkg env (b:bs)
160
  = (env2, fvs2, b':bs')
161
  where
162
163
164
165
166
        -- Notice the mutually-recursive "knot" here:
        --   env accumulates down the list of binds,
        --   fvs accumulates upwards
        (env1, fvs2, b' ) = coreTopBindToStg this_pkg env fvs1 b
        (env2, fvs1, bs') = coreTopBindsToStg this_pkg env1 bs
167
168

coreTopBindToStg
169
170
171
172
173
        :: PackageId
        -> IdEnv HowBound
        -> FreeVarsInfo         -- Info about the body
        -> CoreBind
        -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
174

Simon Marlow's avatar
Simon Marlow committed
175
coreTopBindToStg this_pkg env body_fvs (NonRec id rhs)
176
177
178
  = let
        env'      = extendVarEnv env id how_bound
        how_bound = LetBound TopLet $! manifestArity rhs
179

180
181
        (stg_rhs, fvs') =
            initLne env $ do
twanvl's avatar
twanvl committed
182
183
              (stg_rhs, fvs') <- coreToTopStgRhs this_pkg body_fvs (id,rhs)
              return (stg_rhs, fvs')
184
185

        bind = StgNonRec id stg_rhs
186
    in
187
188
189
190
191
    ASSERT2(consistentCafInfo id bind, ppr id )
      -- NB: previously the assertion printed 'rhs' and 'bind'
      --     as well as 'id', but that led to a black hole
      --     where printing the assertion error tripped the
      --     assertion again!
192
193
    (env', fvs' `unionFVInfo` body_fvs, bind)

Simon Marlow's avatar
Simon Marlow committed
194
coreTopBindToStg this_pkg env body_fvs (Rec pairs)
195
  = ASSERT( not (null pairs) )
196
197
    let
        binders = map fst pairs
198

199
200
201
        extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
                     | (b, rhs) <- pairs ]
        env' = extendVarEnvList env extra_env'
202

203
        (stg_rhss, fvs')
204
205
206
207
          = initLne env' $ do
               (stg_rhss, fvss') <- mapAndUnzipM (coreToTopStgRhs this_pkg body_fvs) pairs
               let fvs' = unionFVInfos fvss'
               return (stg_rhss, fvs')
208

209
        bind = StgRec (zip binders stg_rhss)
210
    in
211
    ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
212
213
    (env', fvs' `unionFVInfo` body_fvs, bind)

214

215
216
217
218
-- Assertion helper: this checks that the CafInfo on the Id matches
-- what CoreToStg has figured out about the binding's SRT.  The
-- CafInfo will be exact in all cases except when CorePrep has
-- floated out a binding, in which case it will be approximate.
Ian Lynagh's avatar
Ian Lynagh committed
219
consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool
220
consistentCafInfo id bind
221
  = WARN( not (exact || is_sat_thing) , ppr id )
222
    safe
223
  where
224
225
226
227
228
    safe  = id_marked_caffy || not binding_is_caffy
    exact = id_marked_caffy == binding_is_caffy
    id_marked_caffy  = mayHaveCafRefs (idCafInfo id)
    binding_is_caffy = stgBindHasCafRefs bind
    is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat"
229
230
231
\end{code}

\begin{code}
232
coreToTopStgRhs
233
234
235
236
        :: PackageId
        -> FreeVarsInfo         -- Free var info for the scope of the binding
        -> (Id,CoreExpr)
        -> LneM (StgRhs, FreeVarsInfo)
237

238
239
240
241
coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs)
  = do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs
       ; lv_info <- freeVarsToLiveVars rhs_fvs

242
       ; let stg_rhs   = mkTopStgRhs this_pkg rhs_fvs (mkSRT lv_info) bndr_info new_rhs
243
             stg_arity = stgRhsArity stg_rhs
244
       ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
245
                 rhs_fvs) }
246
  where
247
    bndr_info = lookupFVInfo scope_fv_info bndr
248

249
250
251
252
253
254
255
256
257
258
        -- It's vital that the arity on a top-level Id matches
        -- the arity of the generated STG binding, else an importing
        -- module will use the wrong calling convention
        --      (Trac #2844 was an example where this happened)
        -- NB1: we can't move the assertion further out without
        --      blocking the "knot" tied in coreTopBindsToStg
        -- NB2: the arity check is only needed for Ids with External
        --      Names, because they are externally visible.  The CorePrep
        --      pass introduces "sat" things with Local Names and does
        --      not bother to set their Arity info, so don't fail for those
259
260
    arity_ok stg_arity
       | isExternalName (idName bndr) = id_arity == stg_arity
261
       | otherwise                    = True
262
263
    id_arity  = idArity bndr
    mk_arity_msg stg_arity
264
        = vcat [ppr bndr,
265
266
267
                ptext (sLit "Id arity:") <+> ppr id_arity,
                ptext (sLit "STG arity:") <+> ppr stg_arity]

268
mkTopStgRhs :: PackageId -> FreeVarsInfo
269
270
            -> SRT -> StgBinderInfo -> StgExpr
            -> StgRhs
271

272
273
mkTopStgRhs _ rhs_fvs srt binder_info (StgLam _ bndrs body)
  = StgRhsClosure noCCS binder_info
274
275
276
277
                  (getFVs rhs_fvs)
                  ReEntrant
                  srt
                  bndrs body
278

279
280
mkTopStgRhs this_pkg _ _ _ (StgConApp con args)
  | not (isDllConApp this_pkg con args)  -- Dynamic StgConApps are updatable
281
282
  = StgRhsCon noCCS con args

283
284
mkTopStgRhs _ rhs_fvs srt binder_info rhs
  = StgRhsClosure noCCS binder_info
285
286
287
288
                  (getFVs rhs_fvs)
                  Updatable
                  srt
                  [] rhs
289
\end{code}
290
291
292
293
294


-- ---------------------------------------------------------------------------
-- Expressions
-- ---------------------------------------------------------------------------
295

296
\begin{code}
297
coreToStgExpr
298
299
300
301
302
303
304
305
        :: CoreExpr
        -> LneM (StgExpr,       -- Decorated STG expr
                 FreeVarsInfo,  -- Its free vars (NB free, not live)
                 EscVarsSet)    -- Its escapees, a subset of its free vars;
                                -- also a subset of the domain of the envt
                                -- because we are only interested in the escapees
                                -- for vars which might be turned into
                                -- let-no-escaped ones.
306
307
\end{code}

308
309
310
311
312
The second and third components can be derived in a simple bottom up pass, not
dependent on any decisions about which variables will be let-no-escaped or
not.  The first component, that is, the decorated expression, may then depend
on these components, but it in turn is not scrutinised as the basis for any
decisions.  Hence no black holes.
313
314

\begin{code}
twanvl's avatar
twanvl committed
315
coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo, emptyVarSet)
316
coreToStgExpr (Var v) = coreToStgApp Nothing v []
sof's avatar
sof committed
317

318
coreToStgExpr expr@(App _ _)
319
320
321
  = coreToStgApp Nothing f args
  where
    (f, args) = myCollectArgs expr
322

323
coreToStgExpr expr@(Lam _ _)
324
  = let
325
326
        (args, body) = myCollectBinders expr
        args'        = filterStgBinders args
327
    in
twanvl's avatar
twanvl committed
328
329
    extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $ do
    (body, body_fvs, body_escs) <- coreToStgExpr body
330
    let
331
332
333
334
        fvs             = args' `minusFVBinders` body_fvs
        escs            = body_escs `delVarSetList` args'
        result_expr | null args' = body
                    | otherwise  = StgLam (exprType expr) args' body
335

twanvl's avatar
twanvl committed
336
337
338
339
340
    return (result_expr, fvs, escs)

coreToStgExpr (Note (SCC cc) expr) = do
    (expr2, fvs, escs) <- coreToStgExpr expr
    return (StgSCC cc expr2, fvs, escs)
341

Ian Lynagh's avatar
Ian Lynagh committed
342
coreToStgExpr (Case (Var id) _bndr _ty [(DEFAULT,[],expr)])
twanvl's avatar
twanvl committed
343
344
345
  | Just (TickBox m n) <- isTickBoxOp_maybe id = do
    (expr2, fvs, escs) <- coreToStgExpr expr
    return (StgTick m n expr2, fvs, escs)
andy@galois.com's avatar
andy@galois.com committed
346

Ian Lynagh's avatar
Ian Lynagh committed
347
coreToStgExpr (Note _ expr)
348
  = coreToStgExpr expr
349

Ian Lynagh's avatar
Ian Lynagh committed
350
coreToStgExpr (Cast expr _)
351
352
  = coreToStgExpr expr

353
354
-- Cases require a little more real work.

twanvl's avatar
twanvl committed
355
356
357
358
359
360
361
coreToStgExpr (Case scrut bndr _ alts) = do
    (alts2, alts_fvs, alts_escs)
       <- extendVarEnvLne [(bndr, LambdaBound)] $ do
            (alts2, fvs_s, escs_s) <- mapAndUnzip3M vars_alt alts
            return ( alts2,
                     unionFVInfos fvs_s,
                     unionVarSets escs_s )
362
    let
363
364
365
366
367
368
369
370
371
372
373
        -- Determine whether the default binder is dead or not
        -- This helps the code generator to avoid generating an assignment
        -- for the case binder (is extremely rare cases) ToDo: remove.
        bndr' | bndr `elementOfFVInfo` alts_fvs = bndr
              | otherwise                       = bndr `setIdOccInfo` IAmDead

        -- Don't consider the default binder as being 'live in alts',
        -- since this is from the point of view of the case expr, where
        -- the default binder is not free.
        alts_fvs_wo_bndr  = bndr `minusFVBinder` alts_fvs
        alts_escs_wo_bndr = alts_escs `delVarSet` bndr
374

twanvl's avatar
twanvl committed
375
    alts_lv_info <- freeVarsToLiveVars alts_fvs_wo_bndr
376

377
378
        -- We tell the scrutinee that everything
        -- live in the alts is live in it, too.
Ian Lynagh's avatar
Ian Lynagh committed
379
    (scrut2, scrut_fvs, _scrut_escs, scrut_lv_info)
twanvl's avatar
twanvl committed
380
381
382
383
384
385
       <- setVarsLiveInCont alts_lv_info $ do
            (scrut2, scrut_fvs, scrut_escs) <- coreToStgExpr scrut
            scrut_lv_info <- freeVarsToLiveVars scrut_fvs
            return (scrut2, scrut_fvs, scrut_escs, scrut_lv_info)

    return (
386
      StgCase scrut2 (getLiveVars scrut_lv_info)
387
388
389
390
391
                     (getLiveVars alts_lv_info)
                     bndr'
                     (mkSRT alts_lv_info)
                     (mkStgAltType bndr alts)
                     alts2,
392
393
      scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
      alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
394
395
396
                -- You might think we should have scrut_escs, not
                -- (getFVSet scrut_fvs), but actually we can't call, and
                -- then return from, a let-no-escape thing.
397
398
      )
  where
399
    vars_alt (con, binders, rhs)
400
401
402
      = let     -- Remove type variables
            binders' = filterStgBinders binders
        in
twanvl's avatar
twanvl committed
403
404
        extendVarEnvLne [(b, LambdaBound) | b <- binders'] $ do
        (rhs2, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
405
        let
406
407
                -- Records whether each param is used in the RHS
            good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
twanvl's avatar
twanvl committed
408
409
410
411

        return ( (con, binders', good_use_mask, rhs2),
                 binders' `minusFVBinders` rhs_fvs,
                 rhs_escs `delVarSetList` binders' )
412
413
                -- ToDo: remove the delVarSet;
                -- since escs won't include any of these binders
414
415
\end{code}

416
417
Lets not only take quite a bit of work, but this is where we convert
then to let-no-escapes, if we wish.
418

419
(Meanwhile, we don't expect to see let-no-escapes...)
420
\begin{code}
twanvl's avatar
twanvl committed
421
422
423
424
425
coreToStgExpr (Let bind body) = do
    (new_let, fvs, escs, _)
       <- mfix (\ ~(_, _, _, no_binder_escapes) ->
             coreToStgLet no_binder_escapes bind body
          )
426

twanvl's avatar
twanvl committed
427
    return (new_let, fvs, escs)
Ian Lynagh's avatar
Ian Lynagh committed
428
429

coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)
430
431
\end{code}

432
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
433
mkStgAltType :: Id -> [CoreAlt] -> AltType
434
435
mkStgAltType bndr alts
  = case splitTyConApp_maybe (repType (idType bndr)) of
436
437
438
439
440
441
442
        Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
                    | isUnLiftedTyCon tc     -> PrimAlt tc
                    | isHiBootTyCon tc       -> look_for_better_tycon
                    | isAlgTyCon tc          -> AlgAlt tc
                    | otherwise              -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
                                                PolyAlt
        Nothing                              -> PolyAlt
443
444

  where
445
   _is_poly_alt_tycon tc
446
        =  isFunTyCon tc
447
        || isPrimTyCon tc   -- "Any" is lifted but primitive
448
449
450
        || isFamilyTyCon tc   -- Type family; e.g. arising from strict
                            -- function application where argument has a
                            -- type-family type
451

452
453
   -- Sometimes, the TyCon is a HiBootTyCon which may not have any
   -- constructors inside it.  Then we can get a better TyCon by
454
   -- grabbing the one from a constructor alternative
455
456
   -- if one exists.
   look_for_better_tycon
457
458
459
460
461
462
463
        | ((DataAlt con, _, _) : _) <- data_alts =
                AlgAlt (dataConTyCon con)
        | otherwise =
                ASSERT(null data_alts)
                PolyAlt
        where
                (data_alts, _deflt) = findDefault alts
464
465
\end{code}

466

467
468
469
470
-- ---------------------------------------------------------------------------
-- Applications
-- ---------------------------------------------------------------------------

471
\begin{code}
472
coreToStgApp
473
474
475
476
477
478
479
         :: Maybe UpdateFlag            -- Just upd <=> this application is
                                        -- the rhs of a thunk binding
                                        --      x = [...] \upd [] -> the_app
                                        -- with specified update flag
        -> Id                           -- Function
        -> [CoreArg]                    -- Arguments
        -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
480

481

Ian Lynagh's avatar
Ian Lynagh committed
482
coreToStgApp _ f args = do
twanvl's avatar
twanvl committed
483
484
    (args', args_fvs) <- coreToStgArgs args
    how_bound <- lookupVarLne f
485
486

    let
487
488
489
490
        n_val_args       = valArgCount args
        not_letrec_bound = not (isLetBound how_bound)
        fun_fvs = singletonFVInfo f how_bound fun_occ
            -- e.g. (f :: a -> int) (x :: a)
491
492
493
            -- Here the free variables are "f", "x" AND the type variable "a"
            -- coreToStgArgs will deal with the arguments recursively

494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
        -- Mostly, the arity info of a function is in the fn's IdInfo
        -- But new bindings introduced by CoreSat may not have no
        -- arity info; it would do us no good anyway.  For example:
        --      let f = \ab -> e in f
        -- No point in having correct arity info for f!
        -- Hence the hasArity stuff below.
        -- NB: f_arity is only consulted for LetBound things
        f_arity   = stgArity f how_bound
        saturated = f_arity <= n_val_args

        fun_occ
         | not_letrec_bound         = noBinderInfo      -- Uninteresting variable
         | f_arity > 0 && saturated = stgSatOcc -- Saturated or over-saturated function call
         | otherwise                = stgUnsatOcc       -- Unsaturated function or thunk

        fun_escs
         | not_letrec_bound      = emptyVarSet  -- Only letrec-bound escapees are interesting
         | f_arity == n_val_args = emptyVarSet  -- A function *or thunk* with an exactly
                                                -- saturated call doesn't escape
                                                -- (let-no-escape applies to 'thunks' too)

         | otherwise         = unitVarSet f     -- Inexact application; it does escape

        -- At the moment of the call:

        --  either the function is *not* let-no-escaped, in which case
        --         nothing is live except live_in_cont
        --      or the function *is* let-no-escaped in which case the
        --         variables it uses are live, but still the function
        --         itself is not.  PS.  In this case, the function's
        --         live vars should already include those of the
        --         continuation, but it does no harm to just union the
        --         two regardless.

        res_ty = exprType (mkApps (Var f) args)
        app = case idDetails f of
                DataConWorkId dc | saturated -> StgConApp dc args'

                -- Some primitive operator that might be implemented as a library call.
                PrimOpId op      -> ASSERT( saturated )
                                    StgOpApp (StgPrimOp op) args' res_ty

                -- A call to some primitive Cmm function.
                FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId)) PrimCallConv _))
                                 -> ASSERT( saturated )
                                    StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty

                -- A regular foreign call.
                FCallId call     -> ASSERT( saturated )
                                    StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
544

545
                TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')
546
                _other           -> StgApp f args'
547
548
        fvs = fun_fvs  `unionFVInfo` args_fvs
        vars = fun_escs `unionVarSet` (getFVSet args_fvs)
549
550
                                -- All the free vars of the args are disqualified
                                -- from being let-no-escaped.
551

552
553
    -- Forcing these fixes a leak in the code generator, noticed while
    -- profiling for trac #4367
554
555
556
557
    app `seq` fvs `seq` seqVarSet vars `seq` return (
        app,
        fvs,
        vars
twanvl's avatar
twanvl committed
558
     )
559
560


561
562
563
564
565
566
567
568

-- ---------------------------------------------------------------------------
-- Argument lists
-- This is the guy that turns applications into A-normal form
-- ---------------------------------------------------------------------------

coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
coreToStgArgs []
twanvl's avatar
twanvl committed
569
  = return ([], emptyFVInfo)
570

Ian Lynagh's avatar
Ian Lynagh committed
571
coreToStgArgs (Type _ : args) = do     -- Type argument
twanvl's avatar
twanvl committed
572
    (args', fvs) <- coreToStgArgs args
573
    return (args', fvs)
574

twanvl's avatar
twanvl committed
575
576
coreToStgArgs (arg : args) = do         -- Non-type argument
    (stg_args, args_fvs) <- coreToStgArgs args
Ian Lynagh's avatar
Ian Lynagh committed
577
    (arg', arg_fvs, _escs) <- coreToStgExpr arg
578
    let
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
        fvs = args_fvs `unionFVInfo` arg_fvs
        stg_arg = case arg' of
                       StgApp v []      -> StgVarArg v
                       StgConApp con [] -> StgVarArg (dataConWorkId con)
                       StgLit lit       -> StgLitArg lit
                       _                -> pprPanic "coreToStgArgs" (ppr arg)

        -- WARNING: what if we have an argument like (v `cast` co)
        --          where 'co' changes the representation type?
        --          (This really only happens if co is unsafe.)
        -- Then all the getArgAmode stuff in CgBindery will set the
        -- cg_rep of the CgIdInfo based on the type of v, rather
        -- than the type of 'co'.
        -- This matters particularly when the function is a primop
        -- or foreign call.
        -- Wanted: a better solution than this hacky warning
595
    let
596
597
598
599
600
601
602
603
604
        arg_ty = exprType arg
        stg_arg_ty = stgArgType stg_arg
        bad_args = (isUnLiftedType arg_ty && not (isUnLiftedType stg_arg_ty))
                || (typePrimRep arg_ty /= typePrimRep stg_arg_ty)
        -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted),
        -- and pass it to a function expecting an HValue (arg_ty).  This is ok because
        -- we can treat an unlifted value as lifted.  But the other way round
        -- we complain.
        -- We also want to check if a pointer is cast to a non-ptr etc
twanvl's avatar
twanvl committed
605

Ian Lynagh's avatar
Ian Lynagh committed
606
    WARN( bad_args, ptext (sLit "Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg )
twanvl's avatar
twanvl committed
607
     return (stg_arg : stg_args, fvs)
608
609


610
611
612
613
614
-- ---------------------------------------------------------------------------
-- The magic for lets:
-- ---------------------------------------------------------------------------

coreToStgLet
615
616
617
618
619
620
621
622
         :: Bool        -- True <=> yes, we are let-no-escaping this let
         -> CoreBind    -- bindings
         -> CoreExpr    -- body
         -> LneM (StgExpr,      -- new let
                  FreeVarsInfo, -- variables free in the whole let
                  EscVarsSet,   -- variables that escape from the whole let
                  Bool)         -- True <=> none of the binders in the bindings
                                -- is among the escaping vars
623

twanvl's avatar
twanvl committed
624
625
626
627
coreToStgLet let_no_escape bind body = do
    (bind2, bind_fvs, bind_escs, bind_lvs,
     body2, body_fvs, body_escs, body_lvs)
       <- mfix $ \ ~(_, _, _, _, _, rec_body_fvs, _, _) -> do
628

twanvl's avatar
twanvl committed
629
630
631
632
          -- Do the bindings, setting live_in_cont to empty if
          -- we ain't in a let-no-escape world
          live_in_cont <- getVarsLiveInCont
          ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext)
633
634
                <- setVarsLiveInCont (if let_no_escape
                                          then live_in_cont
twanvl's avatar
twanvl committed
635
636
                                          else emptyLiveInfo)
                                     (vars_bind rec_body_fvs bind)
637

twanvl's avatar
twanvl committed
638
639
640
641
          -- Do the body
          extendVarEnvLne env_ext $ do
             (body2, body_fvs, body_escs) <- coreToStgExpr body
             body_lv_info <- freeVarsToLiveVars body_fvs
642

twanvl's avatar
twanvl committed
643
644
             return (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
                     body2, body_fvs, body_escs, getLiveVars body_lv_info)
645
646


647
        -- Compute the new let-expression
648
    let
649
650
        new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
                | otherwise     = StgLet bind2 body2
651

652
653
        free_in_whole_let
          = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
654

655
656
        live_in_whole_let
          = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders)
657

658
659
660
661
662
        real_bind_escs = if let_no_escape then
                            bind_escs
                         else
                            getFVSet bind_fvs
                            -- Everything escapes which is free in the bindings
663

664
        let_escs = (real_bind_escs `unionVarSet` body_escs) `delVarSetList` binders
665

666
667
        all_escs = bind_escs `unionVarSet` body_escs    -- Still includes binders of
                                                        -- this let(rec)
668

669
        no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
670

671
672
673
674
675
676
677
678
679
        -- Debugging code as requested by Andrew Kennedy
        checked_no_binder_escapes
                | debugIsOn && not no_binder_escapes && any is_join_var binders
                = pprTrace "Interesting!  A join var that isn't let-no-escaped" (ppr binders)
                  False
                | otherwise = no_binder_escapes

                -- Mustn't depend on the passed-in let_no_escape flag, since
                -- no_binder_escapes is used by the caller to derive the flag!
twanvl's avatar
twanvl committed
680
    return (
681
682
683
684
        new_let,
        free_in_whole_let,
        let_escs,
        checked_no_binder_escapes
twanvl's avatar
twanvl committed
685
      )
686
  where
687
    set_of_binders = mkVarSet binders
688
    binders        = bindersOf bind
689

690
    mk_binding bind_lv_info binder rhs
691
692
693
694
695
696
697
698
699
700
701
702
703
704
        = (binder, LetBound (NestedLet live_vars) (manifestArity rhs))
        where
           live_vars | let_no_escape = addLiveVar bind_lv_info binder
                     | otherwise     = unitLiveVar binder
                -- c.f. the invariant on NestedLet

    vars_bind :: FreeVarsInfo           -- Free var info for body of binding
              -> CoreBind
              -> LneM (StgBinding,
                       FreeVarsInfo,
                       EscVarsSet,        -- free vars; escapee vars
                       LiveInfo,          -- Vars and CAFs live in binding
                       [(Id, HowBound)])  -- extension to environment

705

twanvl's avatar
twanvl committed
706
707
    vars_bind body_fvs (NonRec binder rhs) = do
        (rhs2, bind_fvs, bind_lv_info, escs) <- coreToStgRhs body_fvs [] (binder,rhs)
708
709
        let
            env_ext_item = mk_binding bind_lv_info binder rhs
twanvl's avatar
twanvl committed
710

711
712
        return (StgNonRec binder rhs2,
                bind_fvs, escs, bind_lv_info, [env_ext_item])
713
714
715


    vars_bind body_fvs (Rec pairs)
twanvl's avatar
twanvl committed
716
      = mfix $ \ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
           let
                rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
                binders = map fst pairs
                env_ext = [ mk_binding bind_lv_info b rhs
                          | (b,rhs) <- pairs ]
           in
           extendVarEnvLne env_ext $ do
              (rhss2, fvss, lv_infos, escss)
                     <- mapAndUnzip4M (coreToStgRhs rec_scope_fvs binders) pairs
              let
                        bind_fvs = unionFVInfos fvss
                        bind_lv_info = foldr unionLiveInfo emptyLiveInfo lv_infos
                        escs     = unionVarSets escss

              return (StgRec (binders `zip` rhss2),
                      bind_fvs, escs, bind_lv_info, env_ext)
twanvl's avatar
twanvl committed
733

734
735
736
737

is_join_var :: Id -> Bool
-- A hack (used only for compiler debuggging) to tell if
-- a variable started life as a join point ($j)
738
is_join_var j = occNameString (getOccName j) == "$j"
739
\end{code}
740

741
\begin{code}
742
743
744
745
coreToStgRhs :: FreeVarsInfo            -- Free var info for the scope of the binding
             -> [Id]
             -> (Id,CoreExpr)
             -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet)
746

twanvl's avatar
twanvl committed
747
748
749
750
751
coreToStgRhs scope_fv_info binders (bndr, rhs) = do
    (new_rhs, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
    lv_info <- freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs)
    return (mkStgRhs rhs_fvs (mkSRT lv_info) bndr_info new_rhs,
            rhs_fvs, lv_info, rhs_escs)
752
753
754
  where
    bndr_info = lookupFVInfo scope_fv_info bndr

755
mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs
756

Ian Lynagh's avatar
Ian Lynagh committed
757
mkStgRhs _ _ _ (StgConApp con args) = StgRhsCon noCCS con args
758

759
mkStgRhs rhs_fvs srt binder_info (StgLam _ bndrs body)
760
  = StgRhsClosure noCCS binder_info
761
762
763
764
                  (getFVs rhs_fvs)
                  ReEntrant
                  srt bndrs body

765
mkStgRhs rhs_fvs srt binder_info rhs
766
  = StgRhsClosure noCCS binder_info
767
768
                  (getFVs rhs_fvs)
                  upd_flag srt [] rhs
769
  where
770
771
772
773
774
775
   upd_flag = Updatable
  {-
    SDM: disabled.  Eval/Apply can't handle functions with arity zero very
    well; and making these into simple non-updatable thunks breaks other
    assumptions (namely that they will be entered only once).

776
    upd_flag | isPAP env rhs  = ReEntrant
777
	     | otherwise      = Updatable
778
779
  -}

780
781
{- ToDo:
          upd = if isOnceDem dem
782
783
784
                    then (if isNotTop toplev
                            then SingleEntry    -- HA!  Paydirt for "dem"
                            else
785
786
787
788
#ifdef DEBUG
                     trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
#endif
                     Updatable)
789
                else Updatable
790
791
792
793
        -- For now we forbid SingleEntry CAFs; they tickle the
        -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
        -- and I don't understand why.  There's only one SE_CAF (well,
        -- only one that tickled a great gaping bug in an earlier attempt
794
        -- at ClosureInfo.getEntryConvention) in the whole of nofib,
795
796
797
798
799
800
801
802
803
804
        -- specifically Main.lvl6 in spectral/cryptarithm2.
        -- So no great loss.  KSW 2000-07.
-}
\end{code}

Detect thunks which will reduce immediately to PAPs, and make them
non-updatable.  This has several advantages:

        - the non-updatable thunk behaves exactly like the PAP,

805
806
        - the thunk is more efficient to enter, because it is
          specialised to the task.
807
808

        - we save one update frame, one stg_update_PAP, one update
809
          and lots of PAP_enters.
810

811
812
813
        - in the case where the thunk is top-level, we save building
          a black hole and futhermore the thunk isn't considered to
          be a CAF any more, so it doesn't appear in any SRTs.
814
815
816
817
818
819

We do it here, because the arity information is accurate, and we need
to do it before the SRT pass to save the SRT entries associated with
any top-level PAPs.

isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
820
821
822
                          where
                            arity = stgArity f (lookupBinding env f)
isPAP env _               = False
823

824

825
%************************************************************************
826
%*                                                                      *
827
\subsection[LNE-monad]{A little monad for this let-no-escaping pass}
828
%*                                                                      *
829
830
%************************************************************************

831
There's a lot of stuff to pass around, so we use this @LneM@ monad to
832
help.  All the stuff here is only passed *down*.
833

834
\begin{code}
twanvl's avatar
twanvl committed
835
836
837
838
839
newtype LneM a = LneM
    { unLneM :: IdEnv HowBound
             -> LiveInfo                -- Vars and CAFs live in continuation
             -> a
    }
840

841
842
843
844
type LiveInfo = (StgLiveVars,   -- Dynamic live variables;
                                -- i.e. ones with a nested (non-top-level) binding
                 CafSet)        -- Static live variables;
                                -- i.e. top-level variables that are CAFs or refer to them
845
846
847
848

type EscVarsSet = IdSet
type CafSet     = IdSet

849
data HowBound
850
851
  = ImportBound         -- Used only as a response to lookupBinding; never
                        -- exists in the range of the (IdEnv HowBound)
852

853
854
855
  | LetBound            -- A let(rec) in this module
        LetInfo         -- Whether top level or nested
        Arity           -- Its arity (local Ids don't have arity info at this point)
856

857
  | LambdaBound         -- Used for both lambda and case
858

859
data LetInfo
860
861
862
863
864
  = TopLet              -- top level things
  | NestedLet LiveInfo  -- For nested things, what is live if this
                        -- thing is live?  Invariant: the binder
                        -- itself is always a member of
                        -- the dynamic set of its own LiveInfo
865

Ian Lynagh's avatar
Ian Lynagh committed
866
isLetBound :: HowBound -> Bool
867
isLetBound (LetBound _ _) = True
Ian Lynagh's avatar
Ian Lynagh committed
868
isLetBound _              = False
869

Ian Lynagh's avatar
Ian Lynagh committed
870
871
topLevelBound :: HowBound -> Bool
topLevelBound ImportBound         = True
872
topLevelBound (LetBound TopLet _) = True
Ian Lynagh's avatar
Ian Lynagh committed
873
topLevelBound _                   = False
874
875
\end{code}

876
877
For a let(rec)-bound variable, x, we record LiveInfo, the set of
variables that are live if x is live.  This LiveInfo comprises
878
879
        (a) dynamic live variables (ones with a non-top-level binding)
        (b) static live variabes (CAFs or things that refer to CAFs)
880

881
882
883
884
885
886
887
For "normal" variables (a) is just x alone.  If x is a let-no-escaped
variable then x is represented by a code pointer and a stack pointer
(well, one for each stack).  So all of the variables needed in the
execution of x are live if x is, and are therefore recorded in the
LetBound constructor; x itself *is* included.

The set of dynamic live variables is guaranteed ot have no further let-no-escaped
888
variables in it.
889

890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
\begin{code}
emptyLiveInfo :: LiveInfo
emptyLiveInfo = (emptyVarSet,emptyVarSet)

unitLiveVar :: Id -> LiveInfo
unitLiveVar lv = (unitVarSet lv, emptyVarSet)

unitLiveCaf :: Id -> LiveInfo
unitLiveCaf caf = (emptyVarSet, unitVarSet caf)

addLiveVar :: LiveInfo -> Id -> LiveInfo
addLiveVar (lvs, cafs) id = (lvs `extendVarSet` id, cafs)

unionLiveInfo :: LiveInfo -> LiveInfo -> LiveInfo
unionLiveInfo (lv1,caf1) (lv2,caf2) = (lv1 `unionVarSet` lv2, caf1 `unionVarSet` caf2)

mkSRT :: LiveInfo -> SRT
mkSRT (_, cafs) = SRTEntries cafs

getLiveVars :: LiveInfo -> StgLiveVars
getLiveVars (lvs, _) = lvs
\end{code}


914
915
The std monad functions:
\begin{code}
916
initLne :: IdEnv HowBound -> LneM a -> a
twanvl's avatar
twanvl committed
917
initLne env m = unLneM m env emptyLiveInfo
918

919

920
921
922
923
924

{-# INLINE thenLne #-}
{-# INLINE returnLne #-}

returnLne :: a -> LneM a
Ian Lynagh's avatar
Ian Lynagh committed
925
returnLne e = LneM $ \_ _ -> e
926
927

thenLne :: LneM a -> (a -> LneM b) -> LneM b
twanvl's avatar
twanvl committed
928
929
930
931
932
933
934
935
936
937
938
thenLne m k = LneM $ \env lvs_cont
  -> unLneM (k (unLneM m env lvs_cont)) env lvs_cont

instance Monad LneM where
    return = returnLne
    (>>=)  = thenLne

instance MonadFix LneM where
    mfix expr = LneM $ \env lvs_cont ->
                       let result = unLneM (expr result) env lvs_cont
                       in  result
939
\end{code}
940

941
Functions specific to this monad:
942

943
\begin{code}
944
getVarsLiveInCont :: LneM LiveInfo
Ian Lynagh's avatar
Ian Lynagh committed
945
getVarsLiveInCont = LneM $ \_env lvs_cont -> lvs_cont
946

947
setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
twanvl's avatar
twanvl committed
948
setVarsLiveInCont new_lvs_cont expr
Ian Lynagh's avatar
Ian Lynagh committed
949
   =    LneM $   \env _lvs_cont
twanvl's avatar
twanvl committed
950
   -> unLneM expr env new_lvs_cont
951
952

extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
twanvl's avatar
twanvl committed
953
954
955
extendVarEnvLne ids_w_howbound expr
   =    LneM $   \env lvs_cont
   -> unLneM expr (extendVarEnvList env ids_w_howbound) lvs_cont
956
957

lookupVarLne :: Id -> LneM HowBound
Ian Lynagh's avatar
Ian Lynagh committed
958
lookupVarLne v = LneM $ \env _lvs_cont -> lookupBinding env v
959

960
961
lookupBinding :: IdEnv HowBound -> Id -> HowBound
lookupBinding env v = case lookupVarEnv env v of
962
963
                        Just xx -> xx
                        Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
964

965
966
967
968
969

-- The result of lookupLiveVarsForSet, a set of live variables, is
-- only ever tacked onto a decorated expression. It is never used as
-- the basis of a control decision, which might give a black hole.

970
freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo
twanvl's avatar
twanvl committed
971
972
freeVarsToLiveVars fvs = LneM freeVarsToLiveVars'
 where
Ian Lynagh's avatar
Ian Lynagh committed
973
  freeVarsToLiveVars' _env live_in_cont = live_info
twanvl's avatar
twanvl committed
974
   where
975
976
    live_info    = foldr unionLiveInfo live_in_cont lvs_from_fvs
    lvs_from_fvs = map do_one (allFreeIds fvs)
977

978
979
    do_one (v, how_bound)
      = case how_bound of
980
981
982
983
984
          ImportBound                     -> unitLiveCaf v      -- Only CAF imports are
                                                                -- recorded in fvs
          LetBound TopLet _
                | mayHaveCafRefs (idCafInfo v) -> unitLiveCaf v
                | otherwise                    -> emptyLiveInfo
985

986
987
          LetBound (NestedLet lvs) _      -> lvs        -- lvs already contains v
                                                        -- (see the invariant on NestedLet)
988

989
          _lambda_or_case_binding         -> unitLiveVar v      -- Bound by lambda or case
990
\end{code}
sof's avatar
sof committed
991

992
%************************************************************************
993
%*                                                                      *
994
\subsection[Free-var info]{Free variable information}
995
%*                                                                      *
996
997
998
%************************************************************************

\begin{code}
999
type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo)
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
        -- The Var is so we can gather up the free variables
        -- as a set.
        --
        -- The HowBound info just saves repeated lookups;
        -- we look up just once when we encounter the occurrence.
        -- INVARIANT: Any ImportBound Ids are HaveCafRef Ids
        --            Imported Ids without CAF refs are simply
        --            not put in the FreeVarsInfo for an expression.
        --            See singletonFVInfo and freeVarsToLiveVars
        --
        -- StgBinderInfo records how it occurs; notably, we
        -- are interested in whether it only occurs in saturated
        -- applications, because then we don't need to build a
        -- curried version.
        -- If f is mapped to noBinderInfo, that means
        -- that f *is* mentioned (else it wouldn't be in the
        -- IdEnv at all), but perhaps in an unsaturated applications.
        --
        -- All case/lambda-bound things are also mapped to
        -- noBinderInfo, since we aren't interested in their
        -- occurence info.
        --
        -- For ILX we track free var info for type variables too;
        -- hence VarEnv not IdEnv
1024
1025
\end{code}

1026
\begin{code}
1027
1028
emptyFVInfo :: FreeVarsInfo
emptyFVInfo = emptyVarEnv
1029

1030
singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
1031
-- Don't record non-CAF imports at all, to keep free-var sets small
1032
singletonFVInfo id ImportBound info
1033
   | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info)
1034
   | otherwise                     = emptyVarEnv
1035
singletonFVInfo id how_bound info  = unitVarEnv id (id, how_bound, info)
1036

1037
1038
unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
1039

1040
1041
unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
1042

1043
1044
1045
1046
minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
minusFVBinders vs fv = foldr minusFVBinder fv vs

minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
1047
minusFVBinder v fv = fv `delVarEnv` v
1048
1049
        -- When removing a binder, remember to add its type variables
        -- c.f. CoreFVs.delBinderFV
1050

1051
1052
elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
1053

1054
lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
1055
1056
-- Find how the given Id is used.
-- Externally visible things may be used any old how
1057
lookupFVInfo fvs id
1058
  | isExternalName (idName id) = noBinderInfo
1059
  | otherwise = case lookupVarEnv fvs id of
1060
1061
                        Nothing         -> noBinderInfo
                        Just (_,_,info) -> info
1062

1063
allFreeIds :: FreeVarsInfo -> [(Id,HowBound)]   -- Both top level and non-top-level Ids
1064
1065
allFreeIds fvs = ASSERT( all (isId . fst) ids ) ids
      where
1066
        ids = [(id,how_bound) | (id,how_bound,_) <- varEnvElts fvs]
1067

1068
-- Non-top-level things only, both type variables and ids
1069
1070
1071
getFVs :: FreeVarsInfo -> [Var]
getFVs fvs = [id | (id, how_bound, _) <- varEnvElts fvs,
                    not (topLevelBound how_bound) ]
1072

1073
getFVSet :: FreeVarsInfo -> VarSet
1074
getFVSet fvs = mkVarSet (getFVs fvs)
1075

Ian Lynagh's avatar
Ian Lynagh committed
1076
1077
1078
plusFVInfo :: (Var, HowBound, StgBinderInfo)
           -> (Var, HowBound, StgBinderInfo)
           -> (Var, HowBound, StgBinderInfo)
1079
1080
1081
1082
1083
plusFVInfo (id1,hb1,info1) (id2,hb2,info2)
  = ASSERT (id1 == id2 && hb1 `check_eq_how_bound` hb2)
    (id1, hb1, combineStgBinderInfo info1 info2)

-- The HowBound info for a variable in the FVInfo should be consistent
Ian Lynagh's avatar
Ian Lynagh committed
1084
check_eq_how_bound :: HowBound -> HowBound -> Bool
1085
1086
check_eq_how_bound ImportBound        ImportBound        = True
check_eq_how_bound LambdaBound        LambdaBound        = True
1087
check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_eq_li li1 li2
Ian Lynagh's avatar
Ian Lynagh committed
1088
check_eq_how_bound _                  _                  = False
1089

Ian Lynagh's avatar
Ian Lynagh committed
1090
check_eq_li :: LetInfo -> LetInfo -> Bool
1091
check_eq_li (NestedLet _) (NestedLet _) = True
1092
check_eq_li TopLet        TopLet        = True
Ian Lynagh's avatar
Ian Lynagh committed
1093
check_eq_li _             _             = False
1094
1095
\end{code}

1096
Misc.