Commit 023fc92f authored by Ömer Sinan Ağacan's avatar Ömer Sinan Ağacan

Remove unused LiveVars and SRT fields of StgCase

We also need to update `stgBindHasCafRefs` assertion with this change,
as we no longer have the pre-computed SRT, LiveVars etc. We rename it to
`topStgBindHasCafRefs` and implement it like this:

A non-updatable top-level binding may refer to a CAF by referring to a
top-level definition with CAFs. A top-level definition may have CAFs if
it's updatable. At this point (because this is done after TidyPgm)
top-level Ids (whether imported or defined in this module) are
GlobalIds, so the top-levelness test is easy. (see also comments in the
code)

Reviewers: bgamari, simonpj, austin

Reviewed By: simonpj

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1889

GHC Trac Issues: #11550
parent 489a9a3b
......@@ -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 _srt args body)
cgTopRhs dflags rec bndr (StgRhsClosure cc bi fvs upd_flag 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 _srt args body)
cgRhs name (StgRhsClosure cc bi fvs upd_flag 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 uniq, etc.
_ -- ignore bndr
(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 _live_vars _save_vars bndr _srt alt_type alts) =
cgExpr (StgCase expr bndr 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
stg_binds
<- {-# SCC "Core2Stg" #-}
let 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 srt [] body)
do_top_rhs binder (StgRhsClosure _ bi fv u [] 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 srt [] body')
return (StgRhsClosure caf_ccs bi fv u [] body')
do_top_rhs _ (StgRhsClosure _no_ccs bi fv u srt args body)
do_top_rhs _ (StgRhsClosure _no_ccs bi fv u args body)
= do body' <- do_expr body
return (StgRhsClosure dontCareCCS bi fv u srt args body')
return (StgRhsClosure dontCareCCS bi fv u 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 fv1 fv2 bndr srt alt_type alts) = do
do_expr (StgCase expr bndr alt_type alts) = do
expr' <- do_expr expr
alts' <- mapM do_alt alts
return (StgCase expr' fv1 fv2 bndr srt alt_type alts')
return (StgCase expr' bndr 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 lvs1 lvs2 b e) = do
do_expr (StgLetNoEscape b e) = do
(b,e) <- do_let b e
return (StgLetNoEscape lvs1 lvs2 b e)
return (StgLetNoEscape 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 _srt []
do_rhs (StgRhsClosure _closure_cc _bi _fv _u []
(StgTick (ProfNote cc False{-not tick-} _push)
(StgConApp con args)))
= do collectCC cc
return (StgRhsCon currentCCS con args)
do_rhs (StgRhsClosure _ bi fv u srt args expr) = do
do_rhs (StgRhsClosure _ bi fv u args expr) = do
expr' <- do_expr expr
return (StgRhsClosure currentCCS bi fv u srt args expr')
return (StgRhsClosure currentCCS bi fv u 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,7 +42,6 @@ import MkId (realWorldPrimId)
import Type
import TysWiredIn
import DataCon
import VarSet
import OccName
import Name
import Util
......@@ -74,9 +73,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 srt args expr
StgRhsClosure ccs b_info fvs update_flag args expr
-> StgRhsClosure ccs b_info (unariseIds rho fvs) update_flag
(unariseSRT rho srt) args' (unariseExpr us' rho' expr)
args' (unariseExpr us' rho' expr)
where (us', rho', args') = unariseIdBinders us rho args
StgRhsCon ccs con args
-> StgRhsCon ccs con (unariseArgs rho args)
......@@ -111,10 +110,8 @@ unariseExpr us rho (StgLam xs e)
where
(us', rho', xs') = unariseIdBinders us rho xs
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'
unariseExpr us rho (StgCase e bndr alt_ty alts)
= StgCase (unariseExpr us1 rho e) bndr alt_ty alts'
where
(us1, us2) = splitUniqSupply us
alts' = unariseAlts us2 rho alt_ty bndr alts
......@@ -124,9 +121,8 @@ unariseExpr us rho (StgLet bind e)
where
(us1, us2) = splitUniqSupply us
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)
unariseExpr us rho (StgLetNoEscape bind e)
= StgLetNoEscape (unariseBinding us1 rho bind) (unariseExpr us2 rho e)
where
(us1, us2) = splitUniqSupply us
......@@ -161,13 +157,6 @@ 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)
......@@ -212,6 +201,3 @@ 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,11 +50,10 @@ import Control.Monad (liftM, ap)
-- 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):
-- 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.
......@@ -88,8 +87,7 @@ import Control.Monad (liftM, ap)
-- Note [Collecting live CAF info]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- In this pass we also collect information on which CAFs are live for
-- constructing SRTs (see SRT.hs).
-- In this pass we also collect information on which CAFs are live.
--
-- A top-level Id has CafInfo, which is
--
......@@ -108,24 +106,6 @@ 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]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
......@@ -186,9 +166,9 @@ import Control.Monad (liftM, ap)
-- Setting variable info: top-level, binds, RHSs
-- --------------------------------------------------------------
coreToStg :: DynFlags -> Module -> CoreProgram -> IO [StgBinding]
coreToStg :: DynFlags -> Module -> CoreProgram -> [StgBinding]
coreToStg dflags this_mod pgm
= return pgm'
= pgm'
where (_, _, pgm') = coreTopBindsToStg dflags this_mod emptyVarEnv pgm
coreExprToStg :: CoreExpr -> StgExpr
......@@ -273,7 +253,7 @@ consistentCafInfo id bind
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
binding_is_caffy = topStgBindHasCafRefs bind
is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat"
coreToTopStgRhs
......@@ -285,9 +265,8 @@ 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 (mkSRT lv_info) bndr bndr_info new_rhs
; let stg_rhs = mkTopStgRhs dflags this_mod rhs_fvs 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) }
......@@ -314,7 +293,7 @@ coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs)
text "STG arity:" <+> ppr stg_arity]
mkTopStgRhs :: DynFlags -> Module -> FreeVarsInfo
-> SRT -> Id -> StgBinderInfo -> StgExpr
-> Id -> StgBinderInfo -> StgExpr
-> StgRhs
mkTopStgRhs dflags this_mod = mkStgRhs' con_updateable
......@@ -414,23 +393,12 @@ 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, 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)
(scrut2, scrut_fvs, _scrut_escs) <- coreToStgExpr scrut
return (
StgCase scrut2 (getLiveVars scrut_lv_info)
(getLiveVars alts_lv_info)
bndr'
(mkSRT alts_lv_info)
(mkStgAltType bndr alts)
alts2,
StgCase scrut2 bndr' (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
......@@ -682,39 +650,29 @@ coreToStgLet
-- is among the escaping vars
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
-- 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)
(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
-- 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, getLiveVars bind_lv_info,
body2, body_fvs, body_escs, getLiveVars body_lv_info)
return (bind2, bind_fvs, bind_escs,
body2, body_fvs, body_escs)
-- Compute the new let-expression
let
new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
new_let | let_no_escape = StgLetNoEscape 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
......@@ -747,49 +705,43 @@ coreToStgLet let_no_escape bind body = do
set_of_binders = mkVarSet binders
binders = bindersOf bind
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
mk_binding binder rhs
= (binder, LetBound NestedLet (manifestArity rhs))
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, bind_lv_info, escs) <- coreToStgRhs body_fvs [] (binder,rhs)
(rhs2, bind_fvs, escs) <- coreToStgRhs body_fvs (binder,rhs)
let
env_ext_item = mk_binding bind_lv_info binder rhs
env_ext_item = mk_binding binder rhs
return (StgNonRec binder rhs2,
bind_fvs, escs, bind_lv_info, [env_ext_item])
bind_fvs, escs, [env_ext_item])
vars_bind body_fvs (Rec pairs)
= mfix $ \ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
= mfix $ \ ~(_, rec_rhs_fvs, _, _) ->
let
rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
binders = map fst pairs
env_ext = [ mk_binding bind_lv_info b rhs
env_ext = [ mk_binding b rhs
| (b,rhs) <- pairs ]
in
extendVarEnvLne env_ext $ do
(rhss2, fvss, lv_infos, escss)
<- mapAndUnzip4M (coreToStgRhs rec_scope_fvs binders) pairs
(rhss2, fvss, escss)
<- mapAndUnzip3M (coreToStgRhs rec_scope_fvs) 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)
bind_fvs, escs, env_ext)
is_join_var :: Id -> Bool
......@@ -798,37 +750,35 @@ 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, LiveInfo, EscVarsSet)
-> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
coreToStgRhs scope_fv_info binders (bndr, rhs) = do
coreToStgRhs scope_fv_info (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 bndr_info new_rhs,
rhs_fvs, lv_info, rhs_escs)
return (mkStgRhs rhs_fvs bndr bndr_info new_rhs,
rhs_fvs, rhs_escs)
where
bndr_info = lookupFVInfo scope_fv_info bndr
mkStgRhs :: FreeVarsInfo -> SRT -> Id -> StgBinderInfo -> StgExpr -> StgRhs
mkStgRhs :: FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs
mkStgRhs = mkStgRhs' con_updateable
where con_updateable _ _ = False
mkStgRhs' :: (DataCon -> [StgArg] -> Bool)
-> FreeVarsInfo -> SRT -> Id -> StgBinderInfo -> StgExpr -> StgRhs
mkStgRhs' con_updateable rhs_fvs srt bndr binder_info rhs
-> FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs
mkStgRhs' con_updateable rhs_fvs bndr binder_info rhs
| StgLam bndrs body <- rhs
= StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
ReEntrant
srt bndrs body
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 srt [] rhs
upd_flag [] rhs
where
(_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
......@@ -896,17 +846,10 @@ 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
......@@ -920,10 +863,7 @@ data HowBound
data LetInfo
= 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
| NestedLet
isLetBound :: HowBound -> Bool
isLetBound (LetBound _ _) = True
......@@ -948,31 +888,10 @@ 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 emptyLiveInfo
initLne env m = unLneM m env
......@@ -980,11 +899,11 @@ initLne env m = unLneM m env emptyLiveInfo
{-# 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 lvs_cont
-> unLneM (k (unLneM m env lvs_cont)) env lvs_cont
thenLne m k = LneM $ \env
-> unLneM (k (unLneM m env)) env
instance Functor LneM where
fmap = liftM
......@@ -997,27 +916,19 @@ instance Monad LneM where
(>>=) = thenLne
instance MonadFix LneM where
mfix expr = LneM $ \env lvs_cont ->
let result = unLneM (expr result) env lvs_cont
mfix expr = LneM $ \env ->
let result = unLneM (expr result) env
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 lvs_cont
-> unLneM expr (extendVarEnvList env ids_w_howbound) lvs_cont
= LneM $ \env
-> unLneM expr (extendVarEnvList env ids_w_howbound)
lookupVarLne :: Id -> LneM HowBound
lookupVarLne v = LneM $ \env _lvs_cont -> lookupBinding env v
lookupVarLne v = LneM $ \env -> lookupBinding env v
lookupBinding :: IdEnv HowBound -> Id -> HowBound
lookupBinding env v = case lookupVarEnv env v of
......@@ -1025,32 +936,6 @@ 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
-- the basis of a control decision, which might give a black hole.
freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo
freeVarsToLiveVars fvs = LneM freeVarsToLiveVars'
where
freeVarsToLiveVars' _env live_in_cont = live_info
where
live_info = foldr unionLiveInfo live_in_cont lvs_from_fvs
lvs_from_fvs = map do_one (allFreeIds fvs)
do_one (v, how_bound)
= case how_bound of
ImportBound -> unitLiveCaf v -- Only CAF imports are
-- recorded in fvs
LetBound TopLet _
| mayHaveCafRefs (idCafInfo v) -> unitLiveCaf v
| otherwise -> emptyLiveInfo