Commit 5d73fb61 authored by Ömer Sinan Ağacan's avatar Ömer Sinan Ağacan
Browse files

Revert "Remove unused LiveVars and SRT fields of StgCase and StgLetNoEscape"

This reverts commit 4f9967aa.
parent b49d509b
......@@ -141,7 +141,7 @@ cgTopRhs :: DynFlags -> RecFlag -> Id -> StgRhs -> (CgIdInfo, FCode ())
cgTopRhs dflags _rec bndr (StgRhsCon _cc con args)
= cgTopRhsCon dflags bndr con args
cgTopRhs dflags rec bndr (StgRhsClosure cc bi fvs upd_flag args body)
cgTopRhs dflags rec bndr (StgRhsClosure cc bi fvs upd_flag _srt args body)
= ASSERT(null fvs) -- There should be no free variables
cgTopRhsClosure dflags rec bndr cc bi upd_flag args body
......
......@@ -210,7 +210,7 @@ cgRhs id (StgRhsCon cc con args)
buildDynCon id True cc con args
{- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -}
cgRhs name (StgRhsClosure cc bi fvs upd_flag args body)
cgRhs name (StgRhsClosure cc bi fvs upd_flag _srt args body)
= do dflags <- getDynFlags
mkRhsClosure dflags name cc bi (nonVoidIds fvs) upd_flag args body
......@@ -268,7 +268,7 @@ mkRhsClosure dflags bndr _cc _bi
expr
| let strip = snd . stripStgTicksTop (not . tickishIsCode)
, StgCase (StgApp scrutinee [{-no args-}])
_ -- ignore bndr
_ _ _ _ -- ignore uniq, etc.
(AlgAlt _)
[(DataAlt _, params, _use_mask, sel_expr)] <- strip expr
, StgApp selectee [{-no args-}] <- strip sel_expr
......
......@@ -71,7 +71,7 @@ cgExpr (StgLit lit) = do cmm_lit <- cgLit lit
emitReturn [CmmLit cmm_lit]
cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr }
cgExpr (StgLetNoEscape binds expr) =
cgExpr (StgLetNoEscape _ _ binds expr) =
do { u <- newUnique
; let join_id = mkBlockId u
; cgLneBinds join_id binds
......@@ -79,7 +79,7 @@ cgExpr (StgLetNoEscape binds expr) =
; emitLabel join_id
; return r }
cgExpr (StgCase expr bndr alt_type alts) =
cgExpr (StgCase expr _live_vars _save_vars bndr _srt alt_type alts) =
cgCase expr bndr alt_type alts
cgExpr (StgLam {}) = panic "cgExpr: StgLam"
......@@ -140,7 +140,7 @@ cgLetNoEscapeRhsBody
-> Id
-> StgRhs
-> FCode (CgIdInfo, FCode ())
cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd args body)
cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd _ args body)
= cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body
cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)
= cgLetNoEscapeClosure bndr local_cc cc [] (StgConApp con args)
......
......@@ -1436,8 +1436,8 @@ myCoreToStg :: DynFlags -> Module -> CoreProgram
-> IO ( [StgBinding] -- output program
, CollectedCCs) -- cost centre info (declared and used)
myCoreToStg dflags this_mod prepd_binds = do
let stg_binds
= {-# SCC "Core2Stg" #-}
stg_binds
<- {-# SCC "Core2Stg" #-}
coreToStg dflags this_mod prepd_binds
(stg_binds2, cost_centre_info)
......
......@@ -90,7 +90,7 @@ stgMassageForProfiling dflags mod_name _us stg_binds
----------
do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
do_top_rhs _ (StgRhsClosure _ _ _ _ []
do_top_rhs _ (StgRhsClosure _ _ _ _ _ []
(StgTick (ProfNote _cc False{-not tick-} _push)
(StgConApp con args)))
| not (isDllConApp dflags mod_name con args)
......@@ -100,7 +100,7 @@ stgMassageForProfiling dflags mod_name _us stg_binds
-- isDllConApp checks for LitLit args too
= return (StgRhsCon dontCareCCS con args)
do_top_rhs binder (StgRhsClosure _ bi fv u [] body)
do_top_rhs binder (StgRhsClosure _ bi fv u srt [] body)
= do
-- Top level CAF without a cost centre attached
-- Attach CAF cc (collect if individual CAF ccs)
......@@ -119,11 +119,11 @@ stgMassageForProfiling dflags mod_name _us stg_binds
else
return all_cafs_ccs
body' <- do_expr body
return (StgRhsClosure caf_ccs bi fv u [] body')
return (StgRhsClosure caf_ccs bi fv u srt [] body')
do_top_rhs _ (StgRhsClosure _no_ccs bi fv u args body)
do_top_rhs _ (StgRhsClosure _no_ccs bi fv u srt args body)
= do body' <- do_expr body
return (StgRhsClosure dontCareCCS bi fv u args body')
return (StgRhsClosure dontCareCCS bi fv u srt args body')
do_top_rhs _ (StgRhsCon _ con args)
-- Top-level (static) data is not counted in heap
......@@ -155,10 +155,10 @@ stgMassageForProfiling dflags mod_name _us stg_binds
expr' <- do_expr expr
return (StgTick ti expr')
do_expr (StgCase expr bndr alt_type alts) = do
do_expr (StgCase expr fv1 fv2 bndr srt alt_type alts) = do
expr' <- do_expr expr
alts' <- mapM do_alt alts
return (StgCase expr' bndr alt_type alts')
return (StgCase expr' fv1 fv2 bndr srt alt_type alts')
where
do_alt (id, bs, use_mask, e) = do
e' <- do_expr e
......@@ -168,9 +168,9 @@ stgMassageForProfiling dflags mod_name _us stg_binds
(b,e) <- do_let b e
return (StgLet b e)
do_expr (StgLetNoEscape b e) = do
do_expr (StgLetNoEscape lvs1 lvs2 b e) = do
(b,e) <- do_let b e
return (StgLetNoEscape b e)
return (StgLetNoEscape lvs1 lvs2 b e)
do_expr other = pprPanic "SCCfinal.do_expr" (ppr other)
......@@ -200,15 +200,15 @@ stgMassageForProfiling dflags mod_name _us stg_binds
-- allocation of the constructor to the wrong place (XXX)
-- We should really attach (PushCC cc CurrentCCS) to the rhs,
-- but need to reinstate PushCC for that.
do_rhs (StgRhsClosure _closure_cc _bi _fv _u []
do_rhs (StgRhsClosure _closure_cc _bi _fv _u _srt []
(StgTick (ProfNote cc False{-not tick-} _push)
(StgConApp con args)))
= do collectCC cc
return (StgRhsCon currentCCS con args)
do_rhs (StgRhsClosure _ bi fv u args expr) = do
do_rhs (StgRhsClosure _ bi fv u srt args expr) = do
expr' <- do_expr expr
return (StgRhsClosure currentCCS bi fv u args expr')
return (StgRhsClosure currentCCS bi fv u srt args expr')
do_rhs (StgRhsCon _ con args)
= return (StgRhsCon currentCCS con args)
......
......@@ -127,7 +127,7 @@ statRhs :: Bool -> (Id, StgRhs) -> StatEnv
statRhs top (_, StgRhsCon _ _ _)
= countOne (ConstructorBinds top)
statRhs top (_, StgRhsClosure _ _ fv u _ body)
statRhs top (_, StgRhsClosure _ _ fv u _ _ body)
= statExpr body `combineSE`
countN FreeVariables (length fv) `combineSE`
countOne (
......@@ -153,7 +153,7 @@ statExpr (StgConApp _ _) = countOne ConstructorApps
statExpr (StgOpApp _ _ _) = countOne PrimitiveApps
statExpr (StgTick _ e) = statExpr e
statExpr (StgLetNoEscape binds body)
statExpr (StgLetNoEscape _ _ binds body)
= statBinding False{-not top-level-} binds `combineSE`
statExpr body `combineSE`
countOne LetNoEscapes
......@@ -162,7 +162,7 @@ statExpr (StgLet binds body)
= statBinding False{-not top-level-} binds `combineSE`
statExpr body
statExpr (StgCase expr _ _ alts)
statExpr (StgCase expr _ _ _ _ _ alts)
= statExpr expr `combineSE`
stat_alts alts `combineSE`
countOne StgCases
......
......@@ -42,6 +42,7 @@ import MkId (realWorldPrimId)
import Type
import TysWiredIn
import DataCon
import VarSet
import OccName
import Name
import Util
......@@ -73,9 +74,9 @@ unariseBinding us rho bind = case bind of
unariseRhs :: UniqSupply -> UnariseEnv -> StgRhs -> StgRhs
unariseRhs us rho rhs = case rhs of
StgRhsClosure ccs b_info fvs update_flag args expr
StgRhsClosure ccs b_info fvs update_flag srt args expr
-> StgRhsClosure ccs b_info (unariseIds rho fvs) update_flag
args' (unariseExpr us' rho' expr)
(unariseSRT rho srt) args' (unariseExpr us' rho' expr)
where (us', rho', args') = unariseIdBinders us rho args
StgRhsCon ccs con args
-> StgRhsCon ccs con (unariseArgs rho args)
......@@ -110,8 +111,10 @@ unariseExpr us rho (StgLam xs e)
where
(us', rho', xs') = unariseIdBinders us rho xs
unariseExpr us rho (StgCase e bndr alt_ty alts)
= StgCase (unariseExpr us1 rho e) bndr alt_ty alts'
unariseExpr us rho (StgCase e case_lives alts_lives bndr srt alt_ty alts)
= StgCase (unariseExpr us1 rho e) (unariseLives rho case_lives)
(unariseLives rho alts_lives) bndr (unariseSRT rho srt)
alt_ty alts'
where
(us1, us2) = splitUniqSupply us
alts' = unariseAlts us2 rho alt_ty bndr alts
......@@ -121,8 +124,9 @@ unariseExpr us rho (StgLet bind e)
where
(us1, us2) = splitUniqSupply us
unariseExpr us rho (StgLetNoEscape bind e)
= StgLetNoEscape (unariseBinding us1 rho bind) (unariseExpr us2 rho e)
unariseExpr us rho (StgLetNoEscape live_in_let live_in_bind bind e)
= StgLetNoEscape (unariseLives rho live_in_let) (unariseLives rho live_in_bind)
(unariseBinding us1 rho bind) (unariseExpr us2 rho e)
where
(us1, us2) = splitUniqSupply us
......@@ -157,6 +161,13 @@ unariseAlt us rho (con, xs, uses, e)
(us', rho', xs', uses') = unariseUsedIdBinders us rho xs uses
------------------------
unariseSRT :: UnariseEnv -> SRT -> SRT
unariseSRT _ NoSRT = NoSRT
unariseSRT rho (SRTEntries ids) = SRTEntries (concatMapVarSet (unariseId rho) ids)
unariseLives :: UnariseEnv -> StgLiveVars -> StgLiveVars
unariseLives rho ids = concatMapVarSet (unariseId rho) ids
unariseArgs :: UnariseEnv -> [StgArg] -> [StgArg]
unariseArgs rho = concatMap (unariseArg rho)
......@@ -201,3 +212,6 @@ unariseIdBinder us rho x = case repType (idType x) of
unboxedTupleBindersFrom :: UniqSupply -> Id -> [UnaryType] -> [Id]
unboxedTupleBindersFrom us x tys = zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys
where fs = occNameFS (getOccName x)
concatMapVarSet :: (Var -> [Var]) -> VarSet -> VarSet
concatMapVarSet f xs = mkVarSet [x' | x <- varSetElems xs, x' <- f x]
......@@ -50,10 +50,11 @@ import Control.Monad (liftM, ap)
-- Note [Live vs free]
-- ~~~~~~~~~~~~~~~~~~~
--
-- 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):
-- 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.
......@@ -87,7 +88,8 @@ import Control.Monad (liftM, ap)
-- Note [Collecting live CAF info]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- In this pass we also collect information on which CAFs are live.
-- In this pass we also collect information on which CAFs are live for
-- constructing SRTs (see SRT.hs).
--
-- A top-level Id has CafInfo, which is
--
......@@ -106,6 +108,24 @@ import Control.Monad (liftM, ap)
-- 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]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
......@@ -166,9 +186,9 @@ import Control.Monad (liftM, ap)
-- Setting variable info: top-level, binds, RHSs
-- --------------------------------------------------------------
coreToStg :: DynFlags -> Module -> CoreProgram -> [StgBinding]
coreToStg :: DynFlags -> Module -> CoreProgram -> IO [StgBinding]
coreToStg dflags this_mod pgm
= pgm'
= return pgm'
where (_, _, pgm') = coreTopBindsToStg dflags this_mod emptyVarEnv pgm
coreExprToStg :: CoreExpr -> StgExpr
......@@ -265,8 +285,9 @@ coreToTopStgRhs
coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs)
= do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs
; lv_info <- freeVarsToLiveVars rhs_fvs
; let stg_rhs = mkTopStgRhs dflags this_mod rhs_fvs bndr bndr_info new_rhs
; let stg_rhs = mkTopStgRhs dflags this_mod rhs_fvs (mkSRT lv_info) bndr bndr_info new_rhs
stg_arity = stgRhsArity stg_rhs
; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
rhs_fvs) }
......@@ -293,7 +314,7 @@ coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs)
text "STG arity:" <+> ppr stg_arity]
mkTopStgRhs :: DynFlags -> Module -> FreeVarsInfo
-> Id -> StgBinderInfo -> StgExpr
-> SRT -> Id -> StgBinderInfo -> StgExpr
-> StgRhs
mkTopStgRhs dflags this_mod = mkStgRhs' con_updateable
......@@ -393,12 +414,23 @@ coreToStgExpr (Case scrut bndr _ alts) = do
alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs
alts_escs_wo_bndr = alts_escs `delVarSet` bndr
alts_lv_info <- freeVarsToLiveVars alts_fvs_wo_bndr
-- We tell the scrutinee that everything
-- live in the alts is live in it, too.
(scrut2, scrut_fvs, _scrut_escs) <- coreToStgExpr scrut
(scrut2, scrut_fvs, _scrut_escs, scrut_lv_info)
<- 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 (
StgCase scrut2 bndr' (mkStgAltType bndr alts) alts2,
StgCase scrut2 (getLiveVars scrut_lv_info)
(getLiveVars alts_lv_info)
bndr'
(mkSRT alts_lv_info)
(mkStgAltType bndr alts)
alts2,
scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
-- You might think we should have scrut_escs, not
......@@ -650,29 +682,39 @@ coreToStgLet
-- is among the escaping vars
coreToStgLet let_no_escape bind body = do
(bind2, bind_fvs, bind_escs,
body2, body_fvs, body_escs)
<- mfix $ \ ~(_, _, _, _, rec_body_fvs, _) -> do
( bind2, bind_fvs, bind_escs, env_ext)
<- vars_bind rec_body_fvs bind
(bind2, bind_fvs, bind_escs, bind_lvs,
body2, body_fvs, body_escs, body_lvs)
<- mfix $ \ ~(_, _, _, _, _, rec_body_fvs, _, _) -> do
-- 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)
<- setVarsLiveInCont (if let_no_escape
then live_in_cont
else emptyLiveInfo)
(vars_bind rec_body_fvs bind)
-- Do the body
extendVarEnvLne env_ext $ do
(body2, body_fvs, body_escs) <- coreToStgExpr body
body_lv_info <- freeVarsToLiveVars body_fvs
return (bind2, bind_fvs, bind_escs,
body2, body_fvs, body_escs)
return (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
body2, body_fvs, body_escs, getLiveVars body_lv_info)
-- Compute the new let-expression
let
new_let | let_no_escape = StgLetNoEscape bind2 body2
new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
| otherwise = StgLet bind2 body2
free_in_whole_let
= binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
live_in_whole_let
= bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders)
real_bind_escs = if let_no_escape then
bind_escs
else
......@@ -705,43 +747,49 @@ coreToStgLet let_no_escape bind body = do
set_of_binders = mkVarSet binders
binders = bindersOf bind
mk_binding binder rhs
= (binder, LetBound NestedLet (manifestArity rhs))
mk_binding bind_lv_info binder rhs
= (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
vars_bind body_fvs (NonRec binder rhs) = do
(rhs2, bind_fvs, escs) <- coreToStgRhs body_fvs (binder,rhs)
(rhs2, bind_fvs, bind_lv_info, escs) <- coreToStgRhs body_fvs [] (binder,rhs)
let
env_ext_item = mk_binding binder rhs
env_ext_item = mk_binding bind_lv_info binder rhs
return (StgNonRec binder rhs2,
bind_fvs, escs, [env_ext_item])
bind_fvs, escs, bind_lv_info, [env_ext_item])
vars_bind body_fvs (Rec pairs)
= mfix $ \ ~(_, rec_rhs_fvs, _, _) ->
= mfix $ \ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
let
rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
binders = map fst pairs
env_ext = [ mk_binding b rhs
env_ext = [ mk_binding bind_lv_info b rhs
| (b,rhs) <- pairs ]
in
extendVarEnvLne env_ext $ do
(rhss2, fvss, escss)
<- mapAndUnzip3M (coreToStgRhs rec_scope_fvs) pairs
(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, env_ext)
bind_fvs, escs, bind_lv_info, env_ext)
is_join_var :: Id -> Bool
......@@ -750,35 +798,37 @@ is_join_var :: Id -> Bool
is_join_var j = occNameString (getOccName j) == "$j"
coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding
-> [Id]
-> (Id,CoreExpr)
-> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
-> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet)
coreToStgRhs scope_fv_info (bndr, rhs) = do
coreToStgRhs scope_fv_info binders (bndr, rhs) = do
(new_rhs, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
return (mkStgRhs rhs_fvs bndr bndr_info new_rhs,
rhs_fvs, rhs_escs)
lv_info <- freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs)
return (mkStgRhs rhs_fvs (mkSRT lv_info) bndr bndr_info new_rhs,
rhs_fvs, lv_info, rhs_escs)
where
bndr_info = lookupFVInfo scope_fv_info bndr
mkStgRhs :: FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs
mkStgRhs :: FreeVarsInfo -> SRT -> Id -> StgBinderInfo -> StgExpr -> StgRhs
mkStgRhs = mkStgRhs' con_updateable
where con_updateable _ _ = False
mkStgRhs' :: (DataCon -> [StgArg] -> Bool)
-> FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs
mkStgRhs' con_updateable rhs_fvs bndr binder_info rhs
-> FreeVarsInfo -> SRT -> Id -> StgBinderInfo -> StgExpr -> StgRhs
mkStgRhs' con_updateable rhs_fvs srt bndr binder_info rhs
| StgLam bndrs body <- rhs
= StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
ReEntrant
bndrs body
srt bndrs body
| StgConApp con args <- unticked_rhs
, not (con_updateable con args)
= StgRhsCon noCCS con args
| otherwise
= StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
upd_flag [] rhs
upd_flag srt [] rhs
where
(_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
......@@ -846,10 +896,17 @@ isPAP env _ = False
newtype LneM a = LneM
{ unLneM :: IdEnv HowBound
-> LiveInfo -- Vars and CAFs live in continuation
-> a
}
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
type EscVarsSet = IdSet
type CafSet = IdSet
data HowBound
= ImportBound -- Used only as a response to lookupBinding; never
......@@ -863,7 +920,10 @@ data HowBound
data LetInfo
= TopLet -- top level things
| NestedLet
| 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
isLetBound :: HowBound -> Bool
isLetBound (LetBound _ _) = True
......@@ -888,10 +948,31 @@ topLevelBound _ = False
-- The set of dynamic live variables is guaranteed ot have no further
-- let-no-escaped variables in it.
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
-- The std monad functions:
initLne :: IdEnv HowBound -> LneM a -> a
initLne env m = unLneM m env
initLne env m = unLneM m env emptyLiveInfo
......@@ -899,11 +980,11 @@ initLne env m = unLneM m env
{-# INLINE returnLne #-}
returnLne :: a -> LneM a
returnLne e = LneM $ \_ -> e
returnLne e = LneM $ \_ _ -> e
thenLne :: LneM a -> (a -> LneM b) -> LneM b
thenLne m k = LneM $ \env
-> unLneM (k (unLneM m env)) env
thenLne m k = LneM $ \env lvs_cont
-> unLneM (k (unLneM m env lvs_cont)) env lvs_cont
instance Functor LneM where
fmap = liftM
......@@ -916,19 +997,27 @@ instance Monad LneM where
(>>=) = thenLne
instance MonadFix LneM where
mfix expr = LneM $ \env ->
let result = unLneM (expr result) env
mfix expr = LneM $ \env lvs_cont ->
let result = unLneM (expr result) env lvs_cont
in result
-- Functions specific to this monad:
getVarsLiveInCont :: LneM LiveInfo
getVarsLiveInCont = LneM $ \_env lvs_cont -> lvs_cont
setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
setVarsLiveInCont new_lvs_cont expr
= LneM $ \env _lvs_cont
-> unLneM expr env new_lvs_cont
extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
extendVarEnvLne ids_w_howbound expr
= LneM $ \env
-> unLneM expr (extendVarEnvList env ids_w_howbound)
= LneM $ \env lvs_cont
-> unLneM expr (extendVarEnvList env ids_w_howbound) lvs_cont
lookupVarLne :: Id -> LneM HowBound
lookupVarLne v = LneM $ \env -> lookupBinding env v
lookupVarLne v = LneM $ \env _lvs_cont -> lookupBinding env v
lookupBinding :: IdEnv HowBound -> Id -> HowBound
lookupBinding env v = case lookupVarEnv env v of
......@@ -936,6 +1025,32 @@ lookupBinding env v = case lookupVarEnv env v of
Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
-- The result of lookupLiveVarsForSet, a set of live variables, is
-- only ever tacked onto a decorated expression. It is never used as