CoreToStg.lhs 42.5 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

twanvl's avatar
twanvl committed
548
    return (
549
550
551
552
553
        app,
        fun_fvs  `unionFVInfo` args_fvs,
        fun_escs `unionVarSet` (getFVSet args_fvs)
                                -- All the free vars of the args are disqualified
                                -- from being let-no-escaped.
twanvl's avatar
twanvl committed
554
     )
555
556


557
558
559
560
561
562
563
564

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

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

Ian Lynagh's avatar
Ian Lynagh committed
567
coreToStgArgs (Type _ : args) = do     -- Type argument
twanvl's avatar
twanvl committed
568
    (args', fvs) <- coreToStgArgs args
569
    return (args', fvs)
570

twanvl's avatar
twanvl committed
571
572
coreToStgArgs (arg : args) = do         -- Non-type argument
    (stg_args, args_fvs) <- coreToStgArgs args
Ian Lynagh's avatar
Ian Lynagh committed
573
    (arg', arg_fvs, _escs) <- coreToStgExpr arg
574
    let
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
        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
591
    let
592
593
594
595
596
597
598
599
600
        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
601

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


606
607
608
609
610
-- ---------------------------------------------------------------------------
-- The magic for lets:
-- ---------------------------------------------------------------------------

coreToStgLet
611
612
613
614
615
616
617
618
         :: 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
619

twanvl's avatar
twanvl committed
620
621
622
623
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
624

twanvl's avatar
twanvl committed
625
626
627
628
          -- 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)
629
630
                <- setVarsLiveInCont (if let_no_escape
                                          then live_in_cont
twanvl's avatar
twanvl committed
631
632
                                          else emptyLiveInfo)
                                     (vars_bind rec_body_fvs bind)
633

twanvl's avatar
twanvl committed
634
635
636
637
          -- Do the body
          extendVarEnvLne env_ext $ do
             (body2, body_fvs, body_escs) <- coreToStgExpr body
             body_lv_info <- freeVarsToLiveVars body_fvs
638

twanvl's avatar
twanvl committed
639
640
             return (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
                     body2, body_fvs, body_escs, getLiveVars body_lv_info)
641
642


643
        -- Compute the new let-expression
644
    let
645
646
        new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
                | otherwise     = StgLet bind2 body2
647

648
649
        free_in_whole_let
          = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
650

651
652
        live_in_whole_let
          = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders)
653

654
655
656
657
658
        real_bind_escs = if let_no_escape then
                            bind_escs
                         else
                            getFVSet bind_fvs
                            -- Everything escapes which is free in the bindings
659

660
        let_escs = (real_bind_escs `unionVarSet` body_escs) `delVarSetList` binders
661

662
663
        all_escs = bind_escs `unionVarSet` body_escs    -- Still includes binders of
                                                        -- this let(rec)
664

665
        no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
666

667
668
669
670
671
672
673
674
675
        -- 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
676
    return (
677
678
679
680
        new_let,
        free_in_whole_let,
        let_escs,
        checked_no_binder_escapes
twanvl's avatar
twanvl committed
681
      )
682
  where
683
    set_of_binders = mkVarSet binders
684
    binders        = bindersOf bind
685

686
    mk_binding bind_lv_info binder rhs
687
688
689
690
691
692
693
694
695
696
697
698
699
700
        = (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

701

twanvl's avatar
twanvl committed
702
703
    vars_bind body_fvs (NonRec binder rhs) = do
        (rhs2, bind_fvs, bind_lv_info, escs) <- coreToStgRhs body_fvs [] (binder,rhs)
704
705
        let
            env_ext_item = mk_binding bind_lv_info binder rhs
twanvl's avatar
twanvl committed
706

707
708
        return (StgNonRec binder rhs2,
                bind_fvs, escs, bind_lv_info, [env_ext_item])
709
710
711


    vars_bind body_fvs (Rec pairs)
twanvl's avatar
twanvl committed
712
      = mfix $ \ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
           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
729

730
731
732
733

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

737
\begin{code}
738
739
740
741
coreToStgRhs :: FreeVarsInfo            -- Free var info for the scope of the binding
             -> [Id]
             -> (Id,CoreExpr)
             -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet)
742

twanvl's avatar
twanvl committed
743
744
745
746
747
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)
748
749
750
  where
    bndr_info = lookupFVInfo scope_fv_info bndr

751
mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs
752

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

755
mkStgRhs rhs_fvs srt binder_info (StgLam _ bndrs body)
756
  = StgRhsClosure noCCS binder_info
757
758
759
760
                  (getFVs rhs_fvs)
                  ReEntrant
                  srt bndrs body

761
mkStgRhs rhs_fvs srt binder_info rhs
762
  = StgRhsClosure noCCS binder_info
763
764
                  (getFVs rhs_fvs)
                  upd_flag srt [] rhs
765
  where
766
767
768
769
770
771
   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).

772
    upd_flag | isPAP env rhs  = ReEntrant
773
             | otherwise      = Updatable
774
775
  -}

776
777
{- ToDo:
          upd = if isOnceDem dem
778
779
780
                    then (if isNotTop toplev
                            then SingleEntry    -- HA!  Paydirt for "dem"
                            else
781
782
783
784
#ifdef DEBUG
                     trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
#endif
                     Updatable)
785
                else Updatable
786
787
788
789
        -- 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
790
        -- at ClosureInfo.getEntryConvention) in the whole of nofib,
791
792
793
794
795
796
797
798
799
800
        -- 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,

801
802
        - the thunk is more efficient to enter, because it is
          specialised to the task.
803
804

        - we save one update frame, one stg_update_PAP, one update
805
          and lots of PAP_enters.
806

807
808
809
        - 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.
810
811
812
813
814
815

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
816
817
818
                          where
                            arity = stgArity f (lookupBinding env f)
isPAP env _               = False
819

820

821
%************************************************************************
822
%*                                                                      *
823
\subsection[LNE-monad]{A little monad for this let-no-escaping pass}
824
%*                                                                      *
825
826
%************************************************************************

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

830
\begin{code}
twanvl's avatar
twanvl committed
831
832
833
834
835
newtype LneM a = LneM
    { unLneM :: IdEnv HowBound
             -> LiveInfo                -- Vars and CAFs live in continuation
             -> a
    }
836

837
838
839
840
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
841
842
843
844

type EscVarsSet = IdSet
type CafSet     = IdSet

845
data HowBound
846
847
  = ImportBound         -- Used only as a response to lookupBinding; never
                        -- exists in the range of the (IdEnv HowBound)
848

849
850
851
  | 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)
852

853
  | LambdaBound         -- Used for both lambda and case
854

855
data LetInfo
856
857
858
859
860
  = 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
861

Ian Lynagh's avatar
Ian Lynagh committed
862
isLetBound :: HowBound -> Bool
863
isLetBound (LetBound _ _) = True
Ian Lynagh's avatar
Ian Lynagh committed
864
isLetBound _              = False
865

Ian Lynagh's avatar
Ian Lynagh committed
866
867
topLevelBound :: HowBound -> Bool
topLevelBound ImportBound         = True
868
topLevelBound (LetBound TopLet _) = True
Ian Lynagh's avatar
Ian Lynagh committed
869
topLevelBound _                   = False
870
871
\end{code}

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

877
878
879
880
881
882
883
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
884
variables in it.
885

886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
\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}


910
911
The std monad functions:
\begin{code}
912
initLne :: IdEnv HowBound -> LneM a -> a
twanvl's avatar
twanvl committed
913
initLne env m = unLneM m env emptyLiveInfo
914

915

916
917
918
919
920

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

returnLne :: a -> LneM a
Ian Lynagh's avatar
Ian Lynagh committed
921
returnLne e = LneM $ \_ _ -> e
922
923

thenLne :: LneM a -> (a -> LneM b) -> LneM b
twanvl's avatar
twanvl committed
924
925
926
927
928
929
930
931
932
933
934
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
935
\end{code}
936

937
Functions specific to this monad:
938

939
\begin{code}
940
getVarsLiveInCont :: LneM LiveInfo
Ian Lynagh's avatar
Ian Lynagh committed
941
getVarsLiveInCont = LneM $ \_env lvs_cont -> lvs_cont
942

943
setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
twanvl's avatar
twanvl committed
944
setVarsLiveInCont new_lvs_cont expr
Ian Lynagh's avatar
Ian Lynagh committed
945
   =    LneM $   \env _lvs_cont
twanvl's avatar
twanvl committed
946
   -> unLneM expr env new_lvs_cont
947
948

extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
twanvl's avatar
twanvl committed
949
950
951
extendVarEnvLne ids_w_howbound expr
   =    LneM $   \env lvs_cont
   -> unLneM expr (extendVarEnvList env ids_w_howbound) lvs_cont
952
953

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

956
957
lookupBinding :: IdEnv HowBound -> Id -> HowBound
lookupBinding env v = case lookupVarEnv env v of
958
959
                        Just xx -> xx
                        Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
960

961
962
963
964
965

-- 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.

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

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

982
983
          LetBound (NestedLet lvs) _      -> lvs        -- lvs already contains v
                                                        -- (see the invariant on NestedLet)
984

985
          _lambda_or_case_binding         -> unitLiveVar v      -- Bound by lambda or case
986
\end{code}
sof's avatar
sof committed
987

988
%************************************************************************
989
%*                                                                      *
990
\subsection[Free-var info]{Free variable information}
991
%*                                                                      *
992
993
994
%************************************************************************

\begin{code}
995
type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo)
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
        -- 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
1020
1021
\end{code}

1022
\begin{code}
1023
1024
emptyFVInfo :: FreeVarsInfo
emptyFVInfo = emptyVarEnv
1025

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

1033
1034
unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
1035

1036
1037
unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
1038

1039
1040
1041
1042
minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
minusFVBinders vs fv = foldr minusFVBinder fv vs

minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
1043
minusFVBinder v fv = fv `delVarEnv` v
1044
1045
        -- When removing a binder, remember to add its type variables
        -- c.f. CoreFVs.delBinderFV
1046

1047
1048
elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
1049

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

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

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

1069
getFVSet :: FreeVarsInfo -> VarSet
1070
getFVSet fvs = mkVarSet (getFVs fvs)
1071

Ian Lynagh's avatar
Ian Lynagh committed
1072
1073
1074
plusFVInfo :: (Var, HowBound, StgBinderInfo)
           -> (Var, HowBound, StgBinderInfo)
           -> (Var, HowBound, StgBinderInfo)
1075
1076
1077
1078
1079
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
1080
check_eq_how_bound :: HowBound -> HowBound -> Bool
1081
1082
check_eq_how_bound ImportBound        ImportBound        = True
check_eq_how_bound LambdaBound        LambdaBound        = True
1083
check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_eq_li li1 li2
Ian Lynagh's avatar
Ian Lynagh committed
1084
check_eq_how_bound _                  _                  = False
1085

Ian Lynagh's avatar
Ian Lynagh committed
1086
check_eq_li :: LetInfo -> LetInfo -> Bool
1087
check_eq_li (NestedLet _) (NestedLet _) = True
1088
check_eq_li TopLet        TopLet        = True
Ian Lynagh's avatar
Ian Lynagh committed
1089
check_eq_li _             _             = False
1090
1091
\end{code}

1092
Misc.
1093
\begin{code}
1094
filterStgBinders :: [Var] -> [Var]
1095
filterStgBinders bndrs = filter isId bndrs
simonpj's avatar