CoreToStg.lhs 44.6 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}
Ian Lynagh's avatar
Ian Lynagh committed
10
11
12
13
14
15
16
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

17
module CoreToStg ( coreToStg, coreExprToStg ) where
18

19
#include "HsVersions.h"
20

21
import CoreSyn
22
23
import CoreUtils        ( exprType, findDefault )
import CoreArity        ( manifestArity )
24
import StgSyn
25

26
import Type
27
import TyCon
28
import MkId		( coercionTokenId )
29
30
31
import Id
import IdInfo
import DataCon
32
import CostCentre       ( noCCS )
33
import VarSet
34
import VarEnv
35
36
37
import Maybes           ( maybeToBool )
import Name             ( getOccName, isExternalName, nameOccName )
import OccName          ( occNameString, occNameFS )
38
import BasicTypes       ( Arity )
39
import TysWiredIn       ( unboxedUnitDataCon )
40
import Literal
41
import Outputable
twanvl's avatar
twanvl committed
42
import MonadUtils
43
import FastString
Ian Lynagh's avatar
Ian Lynagh committed
44
import Util
Ian Lynagh's avatar
Ian Lynagh committed
45
import DynFlags
46
import ForeignCall
47
import PrimOp           ( PrimCall(..) )
48
49
\end{code}

50
%************************************************************************
51
%*                                                                      *
52
\subsection[live-vs-free-doc]{Documentation}
53
%*                                                                      *
54
55
%************************************************************************

56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
(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}
73
74
75
        let v = [q] \[x] -> e
        in
        ...v...  (but no q's)
76
77
\end{verbatim}

78
Just after the `in', v is live, but q is dead.  If the whole of that
79
80
let expression was enclosed in a case expression, thus:
\begin{verbatim}
81
82
        case (let v = [q] \[x] -> e in ...v...) of
                alts[...q...]
83
84
85
86
87
88
\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}
89
90
91
        let-no-escape v = [q] \ [x] -> e
        in
        ...v...
92
93
94
95
96
97
\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.
98

99
%************************************************************************
100
%*                                                                      *
101
\subsection[caf-info]{Collecting live CAF info}
102
%*                                                                      *
103
104
%************************************************************************

105
106
In this pass we also collect information on which CAFs are live for
constructing SRTs (see SRT.lhs).
107
108
109

A top-level Id has CafInfo, which is

110
111
112
        - MayHaveCafRefs, if it may refer indirectly to
          one or more CAFs, or
        - NoCafRefs if it definitely doesn't
113

114
The CafInfo has already been calculated during the CoreTidy pass.
115
116
117
118
119
120
121
122
123
124

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.

125
126
127
128
129

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

130
131
132
        let-no-escape x = ...caf1...caf2...
        in
        ...x...x...x...
133

134
where caf1,caf2 are CAFs.  Since x doesn't have a closure, we
135
136
137
138
139
140
141
142
143
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.


144
%************************************************************************
145
%*                                                                      *
146
\subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
147
%*                                                                      *
148
149
150
%************************************************************************

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
151
152
coreToStg :: DynFlags -> CoreProgram -> IO [StgBinding]
coreToStg dflags pgm
153
  = return pgm'
Ian Lynagh's avatar
Ian Lynagh committed
154
  where (_, _, pgm') = coreTopBindsToStg dflags emptyVarEnv pgm
155
156

coreExprToStg :: CoreExpr -> StgExpr
157
coreExprToStg expr
158
159
160
161
  = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)


coreTopBindsToStg
Ian Lynagh's avatar
Ian Lynagh committed
162
    :: DynFlags
163
    -> IdEnv HowBound           -- environment for the bindings
164
    -> CoreProgram
165
166
    -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])

Ian Lynagh's avatar
Ian Lynagh committed
167
coreTopBindsToStg _        env [] = (env, emptyFVInfo, [])
Ian Lynagh's avatar
Ian Lynagh committed
168
coreTopBindsToStg dflags env (b:bs)
169
  = (env2, fvs2, b':bs')
170
  where
171
172
173
        -- Notice the mutually-recursive "knot" here:
        --   env accumulates down the list of binds,
        --   fvs accumulates upwards
Ian Lynagh's avatar
Ian Lynagh committed
174
175
        (env1, fvs2, b' ) = coreTopBindToStg dflags env fvs1 b
        (env2, fvs1, bs') = coreTopBindsToStg dflags env1 bs
176
177

coreTopBindToStg
Ian Lynagh's avatar
Ian Lynagh committed
178
        :: DynFlags
179
180
181
182
        -> IdEnv HowBound
        -> FreeVarsInfo         -- Info about the body
        -> CoreBind
        -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
183

Ian Lynagh's avatar
Ian Lynagh committed
184
coreTopBindToStg dflags env body_fvs (NonRec id rhs)
185
186
187
  = let
        env'      = extendVarEnv env id how_bound
        how_bound = LetBound TopLet $! manifestArity rhs
188

189
190
        (stg_rhs, fvs') =
            initLne env $ do
Ian Lynagh's avatar
Ian Lynagh committed
191
              (stg_rhs, fvs') <- coreToTopStgRhs dflags body_fvs (id,rhs)
twanvl's avatar
twanvl committed
192
              return (stg_rhs, fvs')
193
194

        bind = StgNonRec id stg_rhs
195
    in
196
197
198
199
200
    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!
201
202
    (env', fvs' `unionFVInfo` body_fvs, bind)

Ian Lynagh's avatar
Ian Lynagh committed
203
coreTopBindToStg dflags env body_fvs (Rec pairs)
204
  = ASSERT( not (null pairs) )
205
206
    let
        binders = map fst pairs
207

208
209
210
        extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
                     | (b, rhs) <- pairs ]
        env' = extendVarEnvList env extra_env'
211

212
        (stg_rhss, fvs')
213
          = initLne env' $ do
Ian Lynagh's avatar
Ian Lynagh committed
214
               (stg_rhss, fvss') <- mapAndUnzipM (coreToTopStgRhs dflags body_fvs) pairs
215
216
               let fvs' = unionFVInfos fvss'
               return (stg_rhss, fvs')
217

218
        bind = StgRec (zip binders stg_rhss)
219
    in
220
    ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
221
222
    (env', fvs' `unionFVInfo` body_fvs, bind)

223

224
225
226
227
-- 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
228
consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool
229
consistentCafInfo id bind
230
  = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )
231
    safe
232
  where
233
234
235
236
237
    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"
238
239
240
\end{code}

\begin{code}
241
coreToTopStgRhs
Ian Lynagh's avatar
Ian Lynagh committed
242
        :: DynFlags
243
244
245
        -> FreeVarsInfo         -- Free var info for the scope of the binding
        -> (Id,CoreExpr)
        -> LneM (StgRhs, FreeVarsInfo)
246

Ian Lynagh's avatar
Ian Lynagh committed
247
coreToTopStgRhs dflags scope_fv_info (bndr, rhs)
248
249
250
  = do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs
       ; lv_info <- freeVarsToLiveVars rhs_fvs

Ian Lynagh's avatar
Ian Lynagh committed
251
       ; let stg_rhs   = mkTopStgRhs dflags rhs_fvs (mkSRT lv_info) bndr_info new_rhs
252
             stg_arity = stgRhsArity stg_rhs
253
       ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
254
                 rhs_fvs) }
255
  where
256
    bndr_info = lookupFVInfo scope_fv_info bndr
257

258
259
260
261
262
263
264
265
266
267
        -- 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
268
269
    arity_ok stg_arity
       | isExternalName (idName bndr) = id_arity == stg_arity
270
       | otherwise                    = True
271
272
    id_arity  = idArity bndr
    mk_arity_msg stg_arity
273
        = vcat [ppr bndr,
274
275
276
                ptext (sLit "Id arity:") <+> ppr id_arity,
                ptext (sLit "STG arity:") <+> ppr stg_arity]

Ian Lynagh's avatar
Ian Lynagh committed
277
mkTopStgRhs :: DynFlags -> FreeVarsInfo
278
279
            -> SRT -> StgBinderInfo -> StgExpr
            -> StgRhs
280

281
mkTopStgRhs _ rhs_fvs srt binder_info (StgLam bndrs body)
282
  = StgRhsClosure noCCS binder_info
283
284
285
286
                  (getFVs rhs_fvs)
                  ReEntrant
                  srt
                  bndrs body
287

Ian Lynagh's avatar
Ian Lynagh committed
288
289
mkTopStgRhs dflags _ _ _ (StgConApp con args)
  | not (isDllConApp dflags con args)  -- Dynamic StgConApps are updatable
290
291
  = StgRhsCon noCCS con args

292
293
mkTopStgRhs _ rhs_fvs srt binder_info rhs
  = StgRhsClosure noCCS binder_info
294
295
296
297
                  (getFVs rhs_fvs)
                  Updatable
                  srt
                  [] rhs
298
\end{code}
299
300
301
302
303


-- ---------------------------------------------------------------------------
-- Expressions
-- ---------------------------------------------------------------------------
304

305
\begin{code}
306
coreToStgExpr
307
308
309
310
311
312
313
314
        :: 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.
315
316
\end{code}

317
318
319
320
321
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.
322
323

\begin{code}
324
325
-- No LitInteger's should be left by the time this is called. CorePrep
-- should have converted them all to a real core representation.
326
coreToStgExpr (Lit (LitInteger {})) = panic "coreToStgExpr: LitInteger"
327
328
329
coreToStgExpr (Lit l)      = return (StgLit l, emptyFVInfo, emptyVarSet)
coreToStgExpr (Var v)      = coreToStgApp Nothing v               []
coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId []
sof's avatar
sof committed
330

331
coreToStgExpr expr@(App _ _)
332
333
334
  = coreToStgApp Nothing f args
  where
    (f, args) = myCollectArgs expr
335

336
coreToStgExpr expr@(Lam _ _)
337
  = let
338
339
        (args, body) = myCollectBinders expr
        args'        = filterStgBinders args
340
    in
twanvl's avatar
twanvl committed
341
342
    extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $ do
    (body, body_fvs, body_escs) <- coreToStgExpr body
343
    let
344
345
346
        fvs             = args' `minusFVBinders` body_fvs
        escs            = body_escs `delVarSetList` args'
        result_expr | null args' = body
347
                    | otherwise  = StgLam args' body
348

twanvl's avatar
twanvl committed
349
350
    return (result_expr, fvs, escs)

351
352
353
coreToStgExpr (Tick (HpcTick m n) expr)
  = do (expr2, fvs, escs) <- coreToStgExpr expr
       return (StgTick m n expr2, fvs, escs)
354

355
356
357
coreToStgExpr (Tick (ProfNote cc tick push) expr)
  = do (expr2, fvs, escs) <- coreToStgExpr expr
       return (StgSCC cc tick push expr2, fvs, escs)
andy@galois.com's avatar
andy@galois.com committed
358

359
360
coreToStgExpr (Tick Breakpoint{} _expr)
  = panic "coreToStgExpr: breakpoint should not happen"
361

Ian Lynagh's avatar
Ian Lynagh committed
362
coreToStgExpr (Cast expr _)
363
364
  = coreToStgExpr expr

365
366
-- Cases require a little more real work.

367
368
369
370
371
372
373
374
375
376
377
378
coreToStgExpr (Case scrut _ _ []) 
  = coreToStgExpr scrut   
    -- See Note [Empty case alternatives] in CoreSyn If the case
    -- alternatives are empty, the scrutinee must diverge or raise an
    -- exception, so we can just dive into it.
    --
    -- Of course this may seg-fault if the scrutinee *does* return.  A
    -- belt-and-braces approach would be to move this case into the
    -- code generator, and put a return point anyway that calls a
    -- runtime system error function.
        

twanvl's avatar
twanvl committed
379
380
381
382
383
384
385
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 )
386
    let
387
388
389
390
391
392
393
394
395
396
397
        -- 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
398

twanvl's avatar
twanvl committed
399
    alts_lv_info <- freeVarsToLiveVars alts_fvs_wo_bndr
400

401
402
        -- We tell the scrutinee that everything
        -- live in the alts is live in it, too.
Ian Lynagh's avatar
Ian Lynagh committed
403
    (scrut2, scrut_fvs, _scrut_escs, scrut_lv_info)
twanvl's avatar
twanvl committed
404
405
406
407
408
409
       <- 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 (
410
      StgCase scrut2 (getLiveVars scrut_lv_info)
411
412
413
414
415
                     (getLiveVars alts_lv_info)
                     bndr'
                     (mkSRT alts_lv_info)
                     (mkStgAltType bndr alts)
                     alts2,
416
417
      scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
      alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
418
419
420
                -- 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.
421
422
      )
  where
423
    vars_alt (con, binders, rhs)
424
425
426
427
428
429
430
431
      | DataAlt c <- con, c == unboxedUnitDataCon
      = -- This case is a bit smelly. 
        -- See Note [Nullary unboxed tuple] in Type.lhs
        -- where a nullary tuple is mapped to (State# World#)
        ASSERT( null binders )
        do { (rhs2, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
           ; return ((DEFAULT, [], [], rhs2), rhs_fvs, rhs_escs) }
      | otherwise
432
433
434
      = let     -- Remove type variables
            binders' = filterStgBinders binders
        in
twanvl's avatar
twanvl committed
435
436
        extendVarEnvLne [(b, LambdaBound) | b <- binders'] $ do
        (rhs2, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
437
        let
438
439
                -- Records whether each param is used in the RHS
            good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
twanvl's avatar
twanvl committed
440
441
442
443

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

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

451
(Meanwhile, we don't expect to see let-no-escapes...)
452
\begin{code}
twanvl's avatar
twanvl committed
453
454
455
456
457
coreToStgExpr (Let bind body) = do
    (new_let, fvs, escs, _)
       <- mfix (\ ~(_, _, _, no_binder_escapes) ->
             coreToStgLet no_binder_escapes bind body
          )
458

twanvl's avatar
twanvl committed
459
    return (new_let, fvs, escs)
Ian Lynagh's avatar
Ian Lynagh committed
460
461

coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)
462
463
\end{code}

464
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
465
mkStgAltType :: Id -> [CoreAlt] -> AltType
466
467
468
469
470
471
472
473
474
mkStgAltType bndr alts = case repType (idType bndr) of
    UnaryRep rep_ty -> case tyConAppTyCon_maybe rep_ty of
        Just tc | isUnLiftedTyCon tc -> PrimAlt tc
                | isAbstractTyCon tc -> look_for_better_tycon
                | isAlgTyCon tc      -> AlgAlt tc
                | otherwise          -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
                                        PolyAlt
        Nothing                      -> PolyAlt
    UbxTupleRep rep_tys -> UbxTupAlt (length rep_tys)
475
    -- NB Nullary unboxed tuples have UnaryRep, and generate a PrimAlt
476
  where
477
   _is_poly_alt_tycon tc
478
        =  isFunTyCon tc
479
        || isPrimTyCon tc   -- "Any" is lifted but primitive
480
481
482
        || isFamilyTyCon tc   -- Type family; e.g. arising from strict
                            -- function application where argument has a
                            -- type-family type
483

484
485
   -- Sometimes, the TyCon is a AbstractTyCon which may not have any
   -- constructors inside it.  Then we may get a better TyCon by
486
   -- grabbing the one from a constructor alternative
487
488
   -- if one exists.
   look_for_better_tycon
489
490
491
492
493
494
495
        | ((DataAlt con, _, _) : _) <- data_alts =
                AlgAlt (dataConTyCon con)
        | otherwise =
                ASSERT(null data_alts)
                PolyAlt
        where
                (data_alts, _deflt) = findDefault alts
496
497
\end{code}

498

499
500
501
502
-- ---------------------------------------------------------------------------
-- Applications
-- ---------------------------------------------------------------------------

503
\begin{code}
504
coreToStgApp
505
506
507
508
509
510
511
         :: 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)
512

513

Ian Lynagh's avatar
Ian Lynagh committed
514
coreToStgApp _ f args = do
twanvl's avatar
twanvl committed
515
516
    (args', args_fvs) <- coreToStgArgs args
    how_bound <- lookupVarLne f
517
518

    let
519
520
521
522
        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)
523
524
525
            -- Here the free variables are "f", "x" AND the type variable "a"
            -- coreToStgArgs will deal with the arguments recursively

526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
        -- 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.
569
                FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId) True) PrimCallConv _))
570
571
572
573
574
575
                                 -> 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
576

577
                TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')
578
                _other           -> StgApp f args'
579
580
        fvs = fun_fvs  `unionFVInfo` args_fvs
        vars = fun_escs `unionVarSet` (getFVSet args_fvs)
581
582
                                -- All the free vars of the args are disqualified
                                -- from being let-no-escaped.
583

584
585
    -- Forcing these fixes a leak in the code generator, noticed while
    -- profiling for trac #4367
586
587
588
589
    app `seq` fvs `seq` seqVarSet vars `seq` return (
        app,
        fvs,
        vars
twanvl's avatar
twanvl committed
590
     )
591
592


593
594
595
596
597
598
599
600

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

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

Ian Lynagh's avatar
Ian Lynagh committed
603
coreToStgArgs (Type _ : args) = do     -- Type argument
twanvl's avatar
twanvl committed
604
    (args', fvs) <- coreToStgArgs args
605
    return (args', fvs)
606

607
608
609
610
coreToStgArgs (Coercion _ : args)  -- Coercion argument; replace with place holder
  = do { (args', fvs) <- coreToStgArgs args
       ; return (StgVarArg coercionTokenId : args', fvs) }

twanvl's avatar
twanvl committed
611
612
coreToStgArgs (arg : args) = do         -- Non-type argument
    (stg_args, args_fvs) <- coreToStgArgs args
Ian Lynagh's avatar
Ian Lynagh committed
613
    (arg', arg_fvs, _escs) <- coreToStgExpr arg
614
    let
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
        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
631
    let
632
633
634
        arg_ty = exprType arg
        stg_arg_ty = stgArgType stg_arg
        bad_args = (isUnLiftedType arg_ty && not (isUnLiftedType stg_arg_ty))
635
636
                || (map typePrimRep (flattenRepType (repType arg_ty))
                        /= map typePrimRep (flattenRepType (repType stg_arg_ty)))
637
638
639
640
641
        -- 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
642

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


647
648
649
650
651
-- ---------------------------------------------------------------------------
-- The magic for lets:
-- ---------------------------------------------------------------------------

coreToStgLet
652
653
654
655
656
657
658
659
         :: 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
660

twanvl's avatar
twanvl committed
661
662
663
664
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
665

twanvl's avatar
twanvl committed
666
667
668
669
          -- 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)
670
671
                <- setVarsLiveInCont (if let_no_escape
                                          then live_in_cont
twanvl's avatar
twanvl committed
672
673
                                          else emptyLiveInfo)
                                     (vars_bind rec_body_fvs bind)
674

twanvl's avatar
twanvl committed
675
676
677
678
          -- Do the body
          extendVarEnvLne env_ext $ do
             (body2, body_fvs, body_escs) <- coreToStgExpr body
             body_lv_info <- freeVarsToLiveVars body_fvs
679

twanvl's avatar
twanvl committed
680
681
             return (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
                     body2, body_fvs, body_escs, getLiveVars body_lv_info)
682
683


684
        -- Compute the new let-expression
685
    let
686
687
        new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
                | otherwise     = StgLet bind2 body2
688

689
690
        free_in_whole_let
          = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
691

692
693
        live_in_whole_let
          = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders)
694

695
696
697
698
699
        real_bind_escs = if let_no_escape then
                            bind_escs
                         else
                            getFVSet bind_fvs
                            -- Everything escapes which is free in the bindings
700

701
        let_escs = (real_bind_escs `unionVarSet` body_escs) `delVarSetList` binders
702

703
704
        all_escs = bind_escs `unionVarSet` body_escs    -- Still includes binders of
                                                        -- this let(rec)
705

706
        no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
707

708
709
710
711
712
713
714
715
716
        -- 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
717
    return (
718
719
720
721
        new_let,
        free_in_whole_let,
        let_escs,
        checked_no_binder_escapes
twanvl's avatar
twanvl committed
722
      )
723
  where
724
    set_of_binders = mkVarSet binders
725
    binders        = bindersOf bind
726

727
    mk_binding bind_lv_info binder rhs
728
729
730
731
732
733
734
735
736
737
738
739
740
741
        = (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

742

twanvl's avatar
twanvl committed
743
744
    vars_bind body_fvs (NonRec binder rhs) = do
        (rhs2, bind_fvs, bind_lv_info, escs) <- coreToStgRhs body_fvs [] (binder,rhs)
745
746
        let
            env_ext_item = mk_binding bind_lv_info binder rhs
twanvl's avatar
twanvl committed
747

748
749
        return (StgNonRec binder rhs2,
                bind_fvs, escs, bind_lv_info, [env_ext_item])
750
751
752


    vars_bind body_fvs (Rec pairs)
twanvl's avatar
twanvl committed
753
      = mfix $ \ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
           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
770

771
772
773
774

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

778
\begin{code}
779
780
781
782
coreToStgRhs :: FreeVarsInfo            -- Free var info for the scope of the binding
             -> [Id]
             -> (Id,CoreExpr)
             -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet)
783

twanvl's avatar
twanvl committed
784
785
786
787
788
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)
789
790
791
  where
    bndr_info = lookupFVInfo scope_fv_info bndr

792
mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs
793

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

796
mkStgRhs rhs_fvs srt binder_info (StgLam bndrs body)
797
  = StgRhsClosure noCCS binder_info
798
799
800
801
                  (getFVs rhs_fvs)
                  ReEntrant
                  srt bndrs body

802
mkStgRhs rhs_fvs srt binder_info rhs
803
  = StgRhsClosure noCCS binder_info
804
805
                  (getFVs rhs_fvs)
                  upd_flag srt [] rhs
806
  where
807
808
809
810
811
812
   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).

813
    upd_flag | isPAP env rhs  = ReEntrant
814
	     | otherwise      = Updatable
815
816
  -}

817
818
{- ToDo:
          upd = if isOnceDem dem
819
820
821
                    then (if isNotTop toplev
                            then SingleEntry    -- HA!  Paydirt for "dem"
                            else
Ian Lynagh's avatar
Ian Lynagh committed
822
                     (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $
823
                     Updatable)
824
                else Updatable
825
826
827
828
        -- 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
829
        -- at ClosureInfo.getEntryConvention) in the whole of nofib,
830
831
832
833
834
835
836
837
838
839
        -- 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,

840
841
        - the thunk is more efficient to enter, because it is
          specialised to the task.
842
843

        - we save one update frame, one stg_update_PAP, one update
844
          and lots of PAP_enters.
845

846
847
848
        - 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.
849
850
851
852
853
854

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
855
856
857
                          where
                            arity = stgArity f (lookupBinding env f)
isPAP env _               = False
858

859

860
%************************************************************************
861
%*                                                                      *
862
\subsection[LNE-monad]{A little monad for this let-no-escaping pass}
863
%*                                                                      *
864
865
%************************************************************************

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

869
\begin{code}
twanvl's avatar
twanvl committed
870
871
872
873
874
newtype LneM a = LneM
    { unLneM :: IdEnv HowBound
             -> LiveInfo                -- Vars and CAFs live in continuation
             -> a
    }
875

876
877
878
879
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
880
881
882
883

type EscVarsSet = IdSet
type CafSet     = IdSet

884
data HowBound
885
886
  = ImportBound         -- Used only as a response to lookupBinding; never
                        -- exists in the range of the (IdEnv HowBound)
887

888
889
890
  | 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)
891

892
  | LambdaBound         -- Used for both lambda and case
893

894
data LetInfo
895
896
897
898
899
  = 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
900

Ian Lynagh's avatar
Ian Lynagh committed
901
isLetBound :: HowBound -> Bool
902
isLetBound (LetBound _ _) = True
Ian Lynagh's avatar
Ian Lynagh committed
903
isLetBound _              = False
904

Ian Lynagh's avatar
Ian Lynagh committed
905
906
topLevelBound :: HowBound -> Bool
topLevelBound ImportBound         = True
907
topLevelBound (LetBound TopLet _) = True
Ian Lynagh's avatar
Ian Lynagh committed
908
topLevelBound _                   = False
909
910
\end{code}

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

916
917
918
919
920
921
922
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
923
variables in it.
924

925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
\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}


949
950
The std monad functions:
\begin{code}
951
initLne :: IdEnv HowBound -> LneM a -> a
twanvl's avatar
twanvl committed
952
initLne env m = unLneM m env emptyLiveInfo
953

954

955
956
957
958
959

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

returnLne :: a -> LneM a
Ian Lynagh's avatar
Ian Lynagh committed
960
returnLne e = LneM $ \_ _ -> e
961
962

thenLne :: LneM a -> (a -> LneM b) -> LneM b
twanvl's avatar
twanvl committed
963
964
965
966
967
968
969
970
971
972
973
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
974
\end{code}
975

976
Functions specific to this monad:
977

978
\begin{code}
979
getVarsLiveInCont :: LneM LiveInfo
Ian Lynagh's avatar
Ian Lynagh committed
980
getVarsLiveInCont = LneM $ \_env lvs_cont -> lvs_cont
981

982
setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
twanvl's avatar
twanvl committed
983
setVarsLiveInCont new_lvs_cont expr
Ian Lynagh's avatar
Ian Lynagh committed
984
   =    LneM $   \env _lvs_cont
twanvl's avatar
twanvl committed
985
   -> unLneM expr env new_lvs_cont
986
987

extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
twanvl's avatar
twanvl committed
988
989
990
extendVarEnvLne ids_w_howbound expr
   =    LneM $   \env lvs_cont
   -> unLneM expr (extendVarEnvList env ids_w_howbound) lvs_cont
991
992

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

995
996
lookupBinding :: IdEnv HowBound -> Id -> HowBound
lookupBinding env v = case lookupVarEnv env v of
997
998
                        Just xx -> xx
                        Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
999

1000
1001
1002
1003
1004

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

1005
freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo
twanvl's avatar
twanvl committed
1006
1007
freeVarsToLiveVars fvs = LneM freeVarsToLiveVars'
 where
Ian Lynagh's avatar
Ian Lynagh committed
1008
  freeVarsToLiveVars' _env live_in_cont = live_info
twanvl's avatar
twanvl committed
1009
   where
1010
1011
    live_info    = foldr unionLiveInfo live_in_cont lvs_from_fvs
    lvs_from_fvs = map do_one (allFreeIds fvs)
1012

1013
1014
    do_one (v, how_bound)
      = case how_bound of
1015
1016
1017
1018
1019
          ImportBound                     -> unitLiveCaf v      -- Only CAF imports are
                                                                -- recorded in fvs
          LetBound TopLet _
                | mayHaveCafRefs (idCafInfo v) -> unitLiveCaf v
                | otherwise                    -> emptyLiveInfo
1020

1021
1022
          LetBound (NestedLet lvs) _      -> lvs        -- lvs already contains v
                                                        -- (see the invariant on NestedLet)
1023

1024
          _lambda_or_case_binding         -> unitLiveVar v      -- Bound by lambda or case
1025
\end{code}
sof's avatar
sof committed
1026

1027
%************************************************************************
1028
%*                                                                      *
1029
\subsection[Free-var info]{Free variable information}
1030
%*                                                                      *
1031
1032
1033
%************************************************************************

\begin{code}
1034
type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo)
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
        -- 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
1059
1060
\end{code}

1061
\begin{code}
1062
1063
emptyFVInfo :: FreeVarsInfo
emptyFVInfo = emptyVarEnv
1064

1065
singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
1066
-- Don't record non-CAF imports at all, to keep free-var sets small
1067
singletonFVInfo id ImportBound info
1068
   | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info)
1069
   | otherwise                     = emptyVarEnv
1070
singletonFVInfo id how_bound info  = unitVarEnv id (id, how_bound, info)
1071

1072
1073
unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
1074

1075
1076
unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
1077

1078
1079
1080
1081
minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
minusFVBinders vs fv = foldr minusFVBinder fv vs

minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
1082
minusFVBinder v fv = fv `delVarEnv` v
1083
1084
        -- When removing a binder, remember to add its type variables
        -- c.f. CoreFVs.delBinderFV
1085

1086
1087
elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
1088

1089
lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
1090
1091
-- Find how the given Id is used.
-- Externally visible things may be used any old how
1092
lookupFVInfo fvs id
1093
  | isExternalName (idName id) = noBinderInfo
1094
  | otherwise = case lookupVarEnv fvs id of
1095
1096
                        Nothing         -> noBinderInfo
                        Just (_,_,info) -> info