CoreToStg.lhs 45.6 KB
Newer Older
Jan Stolarek's avatar
Jan Stolarek committed
1 2 3 4
\begin{code}
--
-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
--
5

Jan Stolarek's avatar
Jan Stolarek committed
6 7 8 9 10 11
--------------------------------------------------------------
-- Converting Core to STG Syntax
--------------------------------------------------------------

-- And, as we have the info in hand, we may convert some lets to
-- let-no-escapes.
12

13
module CoreToStg ( coreToStg, coreExprToStg ) where
14

15
#include "HsVersions.h"
16

17
import CoreSyn
18 19
import CoreUtils        ( exprType, findDefault )
import CoreArity        ( manifestArity )
20
import StgSyn
21

22
import Type
23
import TyCon
24
import MkId             ( coercionTokenId )
25 26 27
import Id
import IdInfo
import DataCon
28
import CostCentre       ( noCCS )
29
import VarSet
30
import VarEnv
31
import Maybes           ( maybeToBool )
32
import Module
33 34
import Name             ( getOccName, isExternalName, nameOccName )
import OccName          ( occNameString, occNameFS )
35
import BasicTypes       ( Arity )
36
import TysWiredIn       ( unboxedUnitDataCon )
37
import Literal
38
import Outputable
twanvl's avatar
twanvl committed
39
import MonadUtils
40
import FastString
Ian Lynagh's avatar
Ian Lynagh committed
41
import Util
Ian Lynagh's avatar
Ian Lynagh committed
42
import DynFlags
43
import ForeignCall
Jan Stolarek's avatar
Jan Stolarek committed
44
import Demand           ( isSingleUsed )
45
import PrimOp           ( PrimCall(..) )
46

Austin Seipp's avatar
Austin Seipp committed
47 48
import Control.Monad (liftM, ap)

Jan Stolarek's avatar
Jan Stolarek committed
49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146
-- Note [Live vs free]
-- ~~~~~~~~~~~~~~~~~~~
--
-- The actual Stg datatype is decorated with live variable information, as well
-- as free variable information. The two are 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 directly again. In
-- particular, a dead variable's stack slot (if it has one):
--
--           - should be stubbed to avoid space leaks, and
--           - may be reused for something else.
--
-- There ought to be a better way to say this. Here are some examples:
--
--         let v = [q] \[x] -> e
--         in
--         ...v...  (but no q's)
--
-- Just after the `in', v is live, but q is dead. If the whole of that
-- let expression was enclosed in a case expression, thus:
--
--         case (let v = [q] \[x] -> e in ...v...) of
--                 alts[...q...]
--
-- (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:
--
--         let-no-escape v = [q] \ [x] -> e
--         in
--         ...v...
--
-- 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 its free variables are also live if `v' is.

-- Note [Collecting live CAF info]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- In this pass we also collect information on which CAFs are live for
-- constructing SRTs (see SRT.lhs).
--
-- A top-level Id has CafInfo, which is
--
--         - MayHaveCafRefs, if it may refer indirectly to
--           one or more CAFs, or
--         - NoCafRefs if it definitely doesn't
--
-- The CafInfo has already been calculated during the CoreTidy pass.
--
-- 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.


-- Note [Interaction of let-no-escape with SRTs]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Consider
--
--         let-no-escape x = ...caf1...caf2...
--         in
--         ...x...x...x...
--
-- where caf1,caf2 are CAFs.  Since x doesn't have a closure, we
-- 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.

-- Note [What is a non-escaping let]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- Consider:
--
--     let x = fvs \ args -> e
--     in
--         if ... then x else
--            if ... then x else ...
--
-- `x' is used twice (so we probably can't unfold it), but when it is
-- entered, the stack is deeper than it was when the definition of `x'
-- happened.  Specifically, if instead of allocating a closure for `x',
-- we saved all `x's fvs on the stack, and remembered the stack depth at
-- that moment, then whenever we enter `x' we can simply set the stack
-- pointer(s) to these remembered (compile-time-fixed) values, and jump
-- to the code for `x'.
--
-- All of this is provided x is:
Jan Stolarek's avatar
Jan Stolarek committed
147 148
--   1. non-updatable - it must have at least one parameter (see Note
--      [Join point abstraction]);
Jan Stolarek's avatar
Jan Stolarek committed
149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186
--   2. guaranteed to be entered before the stack retreats -- ie x is not
--      buried in a heap-allocated closure, or passed as an argument to
--      something;
--   3. all the enters have exactly the right number of arguments,
--      no more no less;
--   4. all the enters are tail calls; that is, they return to the
--      caller enclosing the definition of `x'.
--
-- Under these circumstances we say that `x' is non-escaping.
--
-- An example of when (4) does not hold:
--
--     let x = ...
--     in case x of ...alts...
--
-- Here, `x' is certainly entered only when the stack is deeper than when
-- `x' is defined, but here it must return to ...alts... So we can't just
-- adjust the stack down to `x''s recalled points, because that would lost
-- alts' context.
--
-- Things can get a little more complicated.  Consider:
--
--     let y = ...
--     in let x = fvs \ args -> ...y...
--     in ...x...
--
-- Now, if `x' is used in a non-escaping way in ...x..., and `y' is used in a
-- non-escaping way in ...y..., then `y' is non-escaping.
--
-- `x' can even be recursive!  Eg:
--
--     letrec x = [y] \ [v] -> if v then x True else ...
--     in
--         ...(x b)...

-- --------------------------------------------------------------
-- Setting variable info: top-level, binds, RHSs
-- --------------------------------------------------------------
187

188 189
coreToStg :: DynFlags -> Module -> CoreProgram -> IO [StgBinding]
coreToStg dflags this_mod pgm
190
  = return pgm'
191
  where (_, _, pgm') = coreTopBindsToStg dflags this_mod emptyVarEnv pgm
192 193

coreExprToStg :: CoreExpr -> StgExpr
194
coreExprToStg expr
195 196 197 198
  = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)


coreTopBindsToStg
Ian Lynagh's avatar
Ian Lynagh committed
199
    :: DynFlags
200
    -> Module
201
    -> IdEnv HowBound           -- environment for the bindings
202
    -> CoreProgram
203 204
    -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])

205 206
coreTopBindsToStg _      _        env [] = (env, emptyFVInfo, [])
coreTopBindsToStg dflags this_mod env (b:bs)
207
  = (env2, fvs2, b':bs')
208
  where
209 210 211
        -- Notice the mutually-recursive "knot" here:
        --   env accumulates down the list of binds,
        --   fvs accumulates upwards
212 213
        (env1, fvs2, b' ) = coreTopBindToStg dflags this_mod env fvs1 b
        (env2, fvs1, bs') = coreTopBindsToStg dflags this_mod env1 bs
214 215

coreTopBindToStg
Ian Lynagh's avatar
Ian Lynagh committed
216
        :: DynFlags
217
        -> Module
218 219 220 221
        -> IdEnv HowBound
        -> FreeVarsInfo         -- Info about the body
        -> CoreBind
        -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
222

223
coreTopBindToStg dflags this_mod env body_fvs (NonRec id rhs)
224 225 226
  = let
        env'      = extendVarEnv env id how_bound
        how_bound = LetBound TopLet $! manifestArity rhs
227

228 229
        (stg_rhs, fvs') =
            initLne env $ do
230
              (stg_rhs, fvs') <- coreToTopStgRhs dflags this_mod body_fvs (id,rhs)
twanvl's avatar
twanvl committed
231
              return (stg_rhs, fvs')
232 233

        bind = StgNonRec id stg_rhs
234
    in
235 236 237 238 239
    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!
240 241
    (env', fvs' `unionFVInfo` body_fvs, bind)

242
coreTopBindToStg dflags this_mod env body_fvs (Rec pairs)
243
  = ASSERT( not (null pairs) )
244 245
    let
        binders = map fst pairs
246

247 248 249
        extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
                     | (b, rhs) <- pairs ]
        env' = extendVarEnvList env extra_env'
250

251
        (stg_rhss, fvs')
252
          = initLne env' $ do
253
               (stg_rhss, fvss') <- mapAndUnzipM (coreToTopStgRhs dflags this_mod body_fvs) pairs
254 255
               let fvs' = unionFVInfos fvss'
               return (stg_rhss, fvs')
256

257
        bind = StgRec (zip binders stg_rhss)
258
    in
259
    ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
260 261
    (env', fvs' `unionFVInfo` body_fvs, bind)

262

263 264 265 266
-- 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
267
consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool
268
consistentCafInfo id bind
269
  = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )
270
    safe
271
  where
272 273 274 275 276
    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"
277

278
coreToTopStgRhs
Ian Lynagh's avatar
Ian Lynagh committed
279
        :: DynFlags
280
        -> Module
281 282 283
        -> FreeVarsInfo         -- Free var info for the scope of the binding
        -> (Id,CoreExpr)
        -> LneM (StgRhs, FreeVarsInfo)
284

285
coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs)
286 287 288
  = do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs
       ; lv_info <- freeVarsToLiveVars rhs_fvs

289
       ; let stg_rhs   = mkTopStgRhs dflags this_mod rhs_fvs (mkSRT lv_info) bndr bndr_info new_rhs
290
             stg_arity = stgRhsArity stg_rhs
291
       ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
292
                 rhs_fvs) }
293
  where
294
    bndr_info = lookupFVInfo scope_fv_info bndr
295

296 297 298 299 300 301 302 303 304 305
        -- 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
306 307
    arity_ok stg_arity
       | isExternalName (idName bndr) = id_arity == stg_arity
308
       | otherwise                    = True
309 310
    id_arity  = idArity bndr
    mk_arity_msg stg_arity
311
        = vcat [ppr bndr,
312 313 314
                ptext (sLit "Id arity:") <+> ppr id_arity,
                ptext (sLit "STG arity:") <+> ppr stg_arity]

315
mkTopStgRhs :: DynFlags -> Module -> FreeVarsInfo
316
            -> SRT -> Id -> StgBinderInfo -> StgExpr
317
            -> StgRhs
318

319
mkTopStgRhs _ _ rhs_fvs srt _ binder_info (StgLam bndrs body)
320
  = StgRhsClosure noCCS binder_info
321 322 323 324
                  (getFVs rhs_fvs)
                  ReEntrant
                  srt
                  bndrs body
325

326
mkTopStgRhs dflags this_mod _ _ _ _ (StgConApp con args)
327
  | not (isDllConApp dflags this_mod con args)  -- Dynamic StgConApps are updatable
328 329
  = StgRhsCon noCCS con args

330
mkTopStgRhs _ _ rhs_fvs srt bndr binder_info rhs
331
  = StgRhsClosure noCCS binder_info
332
                  (getFVs rhs_fvs)
333
                  (getUpdateFlag bndr)
334 335
                  srt
                  [] rhs
336 337

getUpdateFlag :: Id -> UpdateFlag
Jan Stolarek's avatar
Jan Stolarek committed
338 339 340
getUpdateFlag bndr
  = if isSingleUsed (idDemandInfo bndr)
    then SingleEntry else Updatable
341 342 343 344

-- ---------------------------------------------------------------------------
-- Expressions
-- ---------------------------------------------------------------------------
345

346
coreToStgExpr
347 348 349 350 351 352 353 354
        :: 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.
355

Jan Stolarek's avatar
Jan Stolarek committed
356 357 358 359 360
-- 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.
361

362 363
-- No LitInteger's should be left by the time this is called. CorePrep
-- should have converted them all to a real core representation.
364
coreToStgExpr (Lit (LitInteger {})) = panic "coreToStgExpr: LitInteger"
365 366 367
coreToStgExpr (Lit l)      = return (StgLit l, emptyFVInfo, emptyVarSet)
coreToStgExpr (Var v)      = coreToStgApp Nothing v               []
coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId []
sof's avatar
sof committed
368

369
coreToStgExpr expr@(App _ _)
370 371 372
  = coreToStgApp Nothing f args
  where
    (f, args) = myCollectArgs expr
373

374
coreToStgExpr expr@(Lam _ _)
375
  = let
376 377
        (args, body) = myCollectBinders expr
        args'        = filterStgBinders args
378
    in
twanvl's avatar
twanvl committed
379 380
    extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $ do
    (body, body_fvs, body_escs) <- coreToStgExpr body
381
    let
382 383 384
        fvs             = args' `minusFVBinders` body_fvs
        escs            = body_escs `delVarSetList` args'
        result_expr | null args' = body
385
                    | otherwise  = StgLam args' body
386

twanvl's avatar
twanvl committed
387 388
    return (result_expr, fvs, escs)

389 390 391
coreToStgExpr (Tick (HpcTick m n) expr)
  = do (expr2, fvs, escs) <- coreToStgExpr expr
       return (StgTick m n expr2, fvs, escs)
392

393 394 395
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
396

397 398
coreToStgExpr (Tick Breakpoint{} _expr)
  = panic "coreToStgExpr: breakpoint should not happen"
399

Ian Lynagh's avatar
Ian Lynagh committed
400
coreToStgExpr (Cast expr _)
401 402
  = coreToStgExpr expr

403 404
-- Cases require a little more real work.

405 406
coreToStgExpr (Case scrut _ _ [])
  = coreToStgExpr scrut
407 408 409 410 411 412 413 414
    -- 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.
415

416

twanvl's avatar
twanvl committed
417 418 419 420 421 422 423
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 )
424
    let
425 426 427 428 429 430 431 432 433 434 435
        -- 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
436

twanvl's avatar
twanvl committed
437
    alts_lv_info <- freeVarsToLiveVars alts_fvs_wo_bndr
438

439 440
        -- We tell the scrutinee that everything
        -- live in the alts is live in it, too.
Ian Lynagh's avatar
Ian Lynagh committed
441
    (scrut2, scrut_fvs, _scrut_escs, scrut_lv_info)
twanvl's avatar
twanvl committed
442 443 444 445 446 447
       <- 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 (
448
      StgCase scrut2 (getLiveVars scrut_lv_info)
449 450 451 452 453
                     (getLiveVars alts_lv_info)
                     bndr'
                     (mkSRT alts_lv_info)
                     (mkStgAltType bndr alts)
                     alts2,
454 455
      scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
      alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
456 457 458
                -- 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.
459 460
      )
  where
461
    vars_alt (con, binders, rhs)
462
      | DataAlt c <- con, c == unboxedUnitDataCon
463
      = -- This case is a bit smelly.
464 465 466 467 468 469
        -- 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
470 471 472
      = let     -- Remove type variables
            binders' = filterStgBinders binders
        in
twanvl's avatar
twanvl committed
473 474
        extendVarEnvLne [(b, LambdaBound) | b <- binders'] $ do
        (rhs2, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
475
        let
476 477
                -- Records whether each param is used in the RHS
            good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
twanvl's avatar
twanvl committed
478 479 480 481

        return ( (con, binders', good_use_mask, rhs2),
                 binders' `minusFVBinders` rhs_fvs,
                 rhs_escs `delVarSetList` binders' )
482 483
                -- ToDo: remove the delVarSet;
                -- since escs won't include any of these binders
484

Jan Stolarek's avatar
Jan Stolarek committed
485 486 487 488
-- Lets not only take quite a bit of work, but this is where we convert
-- then to let-no-escapes, if we wish.
-- (Meanwhile, we don't expect to see let-no-escapes...)

489

twanvl's avatar
twanvl committed
490 491 492 493 494
coreToStgExpr (Let bind body) = do
    (new_let, fvs, escs, _)
       <- mfix (\ ~(_, _, _, no_binder_escapes) ->
             coreToStgLet no_binder_escapes bind body
          )
495

twanvl's avatar
twanvl committed
496
    return (new_let, fvs, escs)
Ian Lynagh's avatar
Ian Lynagh committed
497 498

coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)
499

Ian Lynagh's avatar
Ian Lynagh committed
500
mkStgAltType :: Id -> [CoreAlt] -> AltType
501 502 503 504 505 506 507 508 509
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)
510
    -- NB Nullary unboxed tuples have UnaryRep, and generate a PrimAlt
511
  where
512
   _is_poly_alt_tycon tc
513
        =  isFunTyCon tc
514
        || isPrimTyCon tc   -- "Any" is lifted but primitive
515
        || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict
516 517
                            -- function application where argument has a
                            -- type-family type
518

519 520
   -- Sometimes, the TyCon is a AbstractTyCon which may not have any
   -- constructors inside it.  Then we may get a better TyCon by
521
   -- grabbing the one from a constructor alternative
522 523
   -- if one exists.
   look_for_better_tycon
524 525 526 527 528 529 530
        | ((DataAlt con, _, _) : _) <- data_alts =
                AlgAlt (dataConTyCon con)
        | otherwise =
                ASSERT(null data_alts)
                PolyAlt
        where
                (data_alts, _deflt) = findDefault alts
531

532 533 534 535
-- ---------------------------------------------------------------------------
-- Applications
-- ---------------------------------------------------------------------------

536
coreToStgApp
537 538 539 540 541 542 543
         :: 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)
544

545

Ian Lynagh's avatar
Ian Lynagh committed
546
coreToStgApp _ f args = do
twanvl's avatar
twanvl committed
547 548
    (args', args_fvs) <- coreToStgArgs args
    how_bound <- lookupVarLne f
549 550

    let
551 552 553 554
        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)
555 556 557
            -- Here the free variables are "f", "x" AND the type variable "a"
            -- coreToStgArgs will deal with the arguments recursively

558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600
        -- 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.
601
                FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId) True) PrimCallConv _))
602 603 604 605 606 607
                                 -> 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
608

609
                TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')
610
                _other           -> StgApp f args'
611 612
        fvs = fun_fvs  `unionFVInfo` args_fvs
        vars = fun_escs `unionVarSet` (getFVSet args_fvs)
613 614
                                -- All the free vars of the args are disqualified
                                -- from being let-no-escaped.
615

616 617
    -- Forcing these fixes a leak in the code generator, noticed while
    -- profiling for trac #4367
618 619 620 621
    app `seq` fvs `seq` seqVarSet vars `seq` return (
        app,
        fvs,
        vars
twanvl's avatar
twanvl committed
622
     )
623 624


625 626 627 628 629 630 631 632

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

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

Ian Lynagh's avatar
Ian Lynagh committed
635
coreToStgArgs (Type _ : args) = do     -- Type argument
twanvl's avatar
twanvl committed
636
    (args', fvs) <- coreToStgArgs args
637
    return (args', fvs)
638

639 640 641 642
coreToStgArgs (Coercion _ : args)  -- Coercion argument; replace with place holder
  = do { (args', fvs) <- coreToStgArgs args
       ; return (StgVarArg coercionTokenId : args', fvs) }

twanvl's avatar
twanvl committed
643 644
coreToStgArgs (arg : args) = do         -- Non-type argument
    (stg_args, args_fvs) <- coreToStgArgs args
Ian Lynagh's avatar
Ian Lynagh committed
645
    (arg', arg_fvs, _escs) <- coreToStgExpr arg
646
    let
647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662
        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
663
    let
664 665 666
        arg_ty = exprType arg
        stg_arg_ty = stgArgType stg_arg
        bad_args = (isUnLiftedType arg_ty && not (isUnLiftedType stg_arg_ty))
667 668
                || (map typePrimRep (flattenRepType (repType arg_ty))
                        /= map typePrimRep (flattenRepType (repType stg_arg_ty)))
669 670 671 672 673
        -- 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
674

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


679 680 681 682 683
-- ---------------------------------------------------------------------------
-- The magic for lets:
-- ---------------------------------------------------------------------------

coreToStgLet
684 685 686 687 688 689 690 691
         :: 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
692

twanvl's avatar
twanvl committed
693 694 695 696
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
697

twanvl's avatar
twanvl committed
698 699 700 701
          -- 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)
702 703
                <- setVarsLiveInCont (if let_no_escape
                                          then live_in_cont
twanvl's avatar
twanvl committed
704 705
                                          else emptyLiveInfo)
                                     (vars_bind rec_body_fvs bind)
706

twanvl's avatar
twanvl committed
707 708 709 710
          -- Do the body
          extendVarEnvLne env_ext $ do
             (body2, body_fvs, body_escs) <- coreToStgExpr body
             body_lv_info <- freeVarsToLiveVars body_fvs
711

twanvl's avatar
twanvl committed
712 713
             return (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
                     body2, body_fvs, body_escs, getLiveVars body_lv_info)
714 715


716
        -- Compute the new let-expression
717
    let
718 719
        new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
                | otherwise     = StgLet bind2 body2
720

721 722
        free_in_whole_let
          = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
723

724 725
        live_in_whole_let
          = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders)
726

727 728 729 730 731
        real_bind_escs = if let_no_escape then
                            bind_escs
                         else
                            getFVSet bind_fvs
                            -- Everything escapes which is free in the bindings
732

733
        let_escs = (real_bind_escs `unionVarSet` body_escs) `delVarSetList` binders
734

735 736
        all_escs = bind_escs `unionVarSet` body_escs    -- Still includes binders of
                                                        -- this let(rec)
737

738
        no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
739

740 741 742 743 744 745 746 747 748
        -- 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
749
    return (
750 751 752 753
        new_let,
        free_in_whole_let,
        let_escs,
        checked_no_binder_escapes
twanvl's avatar
twanvl committed
754
      )
755
  where
756
    set_of_binders = mkVarSet binders
757
    binders        = bindersOf bind
758

759
    mk_binding bind_lv_info binder rhs
760 761 762 763 764 765 766 767 768 769 770 771 772 773
        = (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

774

twanvl's avatar
twanvl committed
775 776
    vars_bind body_fvs (NonRec binder rhs) = do
        (rhs2, bind_fvs, bind_lv_info, escs) <- coreToStgRhs body_fvs [] (binder,rhs)
777 778
        let
            env_ext_item = mk_binding bind_lv_info binder rhs
twanvl's avatar
twanvl committed
779

780 781
        return (StgNonRec binder rhs2,
                bind_fvs, escs, bind_lv_info, [env_ext_item])
782 783 784


    vars_bind body_fvs (Rec pairs)
twanvl's avatar
twanvl committed
785
      = mfix $ \ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801
           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
802

803 804 805 806

is_join_var :: Id -> Bool
-- A hack (used only for compiler debuggging) to tell if
-- a variable started life as a join point ($j)
807
is_join_var j = occNameString (getOccName j) == "$j"
808

Jan Stolarek's avatar
Jan Stolarek committed
809
coreToStgRhs :: FreeVarsInfo      -- Free var info for the scope of the binding
810 811 812
             -> [Id]
             -> (Id,CoreExpr)
             -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet)
813

twanvl's avatar
twanvl committed
814 815 816
coreToStgRhs scope_fv_info binders (bndr, rhs) = do
    (new_rhs, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
    lv_info <- freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs)
817
    return (mkStgRhs rhs_fvs (mkSRT lv_info) bndr bndr_info new_rhs,
twanvl's avatar
twanvl committed
818
            rhs_fvs, lv_info, rhs_escs)
819 820 821
  where
    bndr_info = lookupFVInfo scope_fv_info bndr

822
mkStgRhs :: FreeVarsInfo -> SRT -> Id -> StgBinderInfo -> StgExpr -> StgRhs
823

824
mkStgRhs _ _ _ _ (StgConApp con args) = StgRhsCon noCCS con args
825

826
mkStgRhs rhs_fvs srt _ binder_info (StgLam bndrs body)
827
  = StgRhsClosure noCCS binder_info
828 829 830 831
                  (getFVs rhs_fvs)
                  ReEntrant
                  srt bndrs body

832
mkStgRhs rhs_fvs srt bndr binder_info rhs
833
  = StgRhsClosure noCCS binder_info
834 835
                  (getFVs rhs_fvs)
                  upd_flag srt [] rhs
836
  where
Jan Stolarek's avatar
Jan Stolarek committed
837
     upd_flag = getUpdateFlag bndr
838 839 840 841 842
  {-
    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).

843
    upd_flag | isPAP env rhs  = ReEntrant
844
             | otherwise      = Updatable
Jan Stolarek's avatar
Jan Stolarek committed
845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870

-- 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,
--
--         - the thunk is more efficient to enter, because it is
--           specialised to the task.
--
--         - we save one update frame, one stg_update_PAP, one update
--           and lots of PAP_enters.
--
--         - 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.
--
-- 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
                              where
                                 arity = stgArity f (lookupBinding env f)
isPAP env _               = False

-}
871

872 873
{- ToDo:
          upd = if isOnceDem dem
874 875 876
                    then (if isNotTop toplev
                            then SingleEntry    -- HA!  Paydirt for "dem"
                            else
Ian Lynagh's avatar
Ian Lynagh committed
877
                     (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $
878
                     Updatable)
879
                else Updatable
880 881 882 883
        -- 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
884
        -- at ClosureInfo.getEntryConvention) in the whole of nofib,
885 886 887 888
        -- specifically Main.lvl6 in spectral/cryptarithm2.
        -- So no great loss.  KSW 2000-07.
-}

Jan Stolarek's avatar
Jan Stolarek committed
889 890 891
-- ---------------------------------------------------------------------------
-- A little monad for this let-no-escaping pass
-- ---------------------------------------------------------------------------
892

Jan Stolarek's avatar
Jan Stolarek committed
893 894
-- There's a lot of stuff to pass around, so we use this LneM monad to
-- help.  All the stuff here is only passed *down*.
895

twanvl's avatar
twanvl committed
896 897 898 899 900
newtype LneM a = LneM
    { unLneM :: IdEnv HowBound
             -> LiveInfo                -- Vars and CAFs live in continuation
             -> a
    }
901

902 903 904 905
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
906 907 908 909

type EscVarsSet = IdSet
type CafSet     = IdSet

910
data HowBound
911 912
  = ImportBound         -- Used only as a response to lookupBinding; never
                        -- exists in the range of the (IdEnv HowBound)
913

914 915 916
  | 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)
917

918
  | LambdaBound         -- Used for both lambda and case
919

920
data LetInfo
921 922 923 924 925
  = 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
926

Ian Lynagh's avatar
Ian Lynagh committed
927
isLetBound :: HowBound -> Bool
928
isLetBound (LetBound _ _) = True
Ian Lynagh's avatar
Ian Lynagh committed
929
isLetBound _              = False
930

Ian Lynagh's avatar
Ian Lynagh committed
931 932
topLevelBound :: HowBound -> Bool
topLevelBound ImportBound         = True
933
topLevelBound (LetBound TopLet _) = True
Ian Lynagh's avatar
Ian Lynagh committed
934
topLevelBound _                   = False
935

Jan Stolarek's avatar
Jan Stolarek committed
936 937 938 939 940 941 942 943 944 945 946 947 948
-- For a let(rec)-bound variable, x, we record LiveInfo, the set of
-- variables that are live if x is live.  This LiveInfo comprises
--         (a) dynamic live variables (ones with a non-top-level binding)
--         (b) static live variabes (CAFs or things that refer to CAFs)
--
-- 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 variables in it.
949

950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970
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

Jan Stolarek's avatar
Jan Stolarek committed
971
-- The std monad functions:
972

973
initLne :: IdEnv HowBound -> LneM a -> a
twanvl's avatar
twanvl committed
974
initLne env m = unLneM m env emptyLiveInfo
975

976

977 978 979 980 981

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

returnLne :: a -> LneM a
Ian Lynagh's avatar
Ian Lynagh committed
982
returnLne e = LneM $ \_ _ -> e
983 984

thenLne :: LneM a -> (a -> LneM b) -> LneM b
twanvl's avatar
twanvl committed
985 986 987
thenLne m k = LneM $ \env lvs_cont
  -> unLneM (k (unLneM m env lvs_cont)) env lvs_cont

Austin Seipp's avatar
Austin Seipp committed
988 989 990 991 992 993 994
instance Functor LneM where
    fmap = liftM

instance Applicative LneM where
    pure = return
    (<*>) = ap

twanvl's avatar
twanvl committed
995 996 997 998 999 1000 1001 1002
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
1003

Jan Stolarek's avatar
Jan Stolarek committed
1004
-- Functions specific to this monad:
1005

1006
getVarsLiveInCont :: LneM LiveInfo
Ian Lynagh's avatar
Ian Lynagh committed
1007
getVarsLiveInCont = LneM $ \_env lvs_cont -> lvs_cont
1008

1009
setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
twanvl's avatar
twanvl committed
1010
setVarsLiveInCont new_lvs_cont expr
Ian Lynagh's avatar
Ian Lynagh committed
1011
   =    LneM $   \env _lvs_cont
twanvl's avatar
twanvl committed
1012
   -> unLneM expr env new_lvs_cont
1013 1014

extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
twanvl's avatar
twanvl committed
1015 1016 1017
extendVarEnvLne ids_w_howbound expr
   =    LneM $   \env lvs_cont
   -> unLneM expr (extendVarEnvList env ids_w_howbound) lvs_cont
1018 1019

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

1022 1023
lookupBinding :: IdEnv HowBound -> Id -> HowBound
lookupBinding env v = case lookupVarEnv env v of
1024 1025
                        Just xx -> xx
                        Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
1026

1027 1028 1029 1030 1031

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

1032
freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo
twanvl's avatar
twanvl committed
1033 1034
freeVarsToLiveVars fvs = LneM freeVarsToLiveVars'
 where
Ian Lynagh's avatar
Ian Lynagh committed
1035
  freeVarsToLiveVars' _env live_in_cont = live_info
twanvl's avatar
twanvl committed
1036
   where
1037 1038
    live_info    = foldr unionLiveInfo live_in_cont lvs_from_fvs
    lvs_from_fvs = map do_one (allFreeIds fvs)
1039

1040 1041
    do_one (v, how_bound)
      = case how_bound of
1042 1043 1044 1045 1046
          ImportBound                     -> unitLiveCaf v      -- Only CAF imports are
                                                                -- recorded in fvs
          LetBound TopLet _
                | mayHaveCafRefs (idCafInfo v) -> unitLiveCaf v
                | otherwise                    -> emptyLiveInfo
1047

1048 1049
          LetBound (NestedLet lvs) _      -> lvs        -- lvs already contains v
                                                        -- (see the invariant on NestedLet)
1050

1051
          _lambda_or_case_binding         -> unitLiveVar v      -- Bound by lambda or case
sof's avatar
sof committed
1052

1053

Jan Stolarek's avatar
Jan Stolarek committed
1054 1055 1056 1057
-- ---------------------------------------------------------------------------
-- Free variable information
-- ---------------------------------------------------------------------------

1058
type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo)
1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082
        -- 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
1083

1084 1085
emptyFVInfo :: FreeVarsInfo
emptyFVInfo = emptyVarEnv
1086

1087
singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
1088
-- Don't record non-CAF imports at all, to keep free-var sets small
1089
singletonFVInfo id ImportBound info
1090
   | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info)
1091
   | otherwise                     = emptyVarEnv
1092
singletonFVInfo id how_bound info  = unitVarEnv id (id, how_bound, info)
1093

1094 1095
unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
1096

1097 1098
unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs