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 ()) ...@@ -141,7 +141,7 @@ cgTopRhs :: DynFlags -> RecFlag -> Id -> StgRhs -> (CgIdInfo, FCode ())
cgTopRhs dflags _rec bndr (StgRhsCon _cc con args) cgTopRhs dflags _rec bndr (StgRhsCon _cc con args)
= cgTopRhsCon dflags bndr 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 = ASSERT(null fvs) -- There should be no free variables
cgTopRhsClosure dflags rec bndr cc bi upd_flag args body cgTopRhsClosure dflags rec bndr cc bi upd_flag args body
......
...@@ -210,7 +210,7 @@ cgRhs id (StgRhsCon cc con args) ...@@ -210,7 +210,7 @@ cgRhs id (StgRhsCon cc con args)
buildDynCon id True cc con args buildDynCon id True cc con args
{- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -} {- 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 = do dflags <- getDynFlags
mkRhsClosure dflags name cc bi (nonVoidIds fvs) upd_flag args body mkRhsClosure dflags name cc bi (nonVoidIds fvs) upd_flag args body
...@@ -268,7 +268,7 @@ mkRhsClosure dflags bndr _cc _bi ...@@ -268,7 +268,7 @@ mkRhsClosure dflags bndr _cc _bi
expr expr
| let strip = snd . stripStgTicksTop (not . tickishIsCode) | let strip = snd . stripStgTicksTop (not . tickishIsCode)
, StgCase (StgApp scrutinee [{-no args-}]) , StgCase (StgApp scrutinee [{-no args-}])
_ -- ignore bndr _ _ _ _ -- ignore uniq, etc.
(AlgAlt _) (AlgAlt _)
[(DataAlt _, params, _use_mask, sel_expr)] <- strip expr [(DataAlt _, params, _use_mask, sel_expr)] <- strip expr
, StgApp selectee [{-no args-}] <- strip sel_expr , StgApp selectee [{-no args-}] <- strip sel_expr
......
...@@ -71,7 +71,7 @@ cgExpr (StgLit lit) = do cmm_lit <- cgLit lit ...@@ -71,7 +71,7 @@ cgExpr (StgLit lit) = do cmm_lit <- cgLit lit
emitReturn [CmmLit cmm_lit] emitReturn [CmmLit cmm_lit]
cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr } cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr }
cgExpr (StgLetNoEscape binds expr) = cgExpr (StgLetNoEscape _ _ binds expr) =
do { u <- newUnique do { u <- newUnique
; let join_id = mkBlockId u ; let join_id = mkBlockId u
; cgLneBinds join_id binds ; cgLneBinds join_id binds
...@@ -79,7 +79,7 @@ cgExpr (StgLetNoEscape binds expr) = ...@@ -79,7 +79,7 @@ cgExpr (StgLetNoEscape binds expr) =
; emitLabel join_id ; emitLabel join_id
; return r } ; 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 cgCase expr bndr alt_type alts
cgExpr (StgLam {}) = panic "cgExpr: StgLam" cgExpr (StgLam {}) = panic "cgExpr: StgLam"
...@@ -140,7 +140,7 @@ cgLetNoEscapeRhsBody ...@@ -140,7 +140,7 @@ cgLetNoEscapeRhsBody
-> Id -> Id
-> StgRhs -> StgRhs
-> FCode (CgIdInfo, FCode ()) -> 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 = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body
cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args) cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)
= cgLetNoEscapeClosure bndr local_cc cc [] (StgConApp con args) = cgLetNoEscapeClosure bndr local_cc cc [] (StgConApp con args)
......
...@@ -1436,8 +1436,8 @@ myCoreToStg :: DynFlags -> Module -> CoreProgram ...@@ -1436,8 +1436,8 @@ myCoreToStg :: DynFlags -> Module -> CoreProgram
-> IO ( [StgBinding] -- output program -> IO ( [StgBinding] -- output program
, CollectedCCs) -- cost centre info (declared and used) , CollectedCCs) -- cost centre info (declared and used)
myCoreToStg dflags this_mod prepd_binds = do myCoreToStg dflags this_mod prepd_binds = do
let stg_binds stg_binds
= {-# SCC "Core2Stg" #-} <- {-# SCC "Core2Stg" #-}
coreToStg dflags this_mod prepd_binds coreToStg dflags this_mod prepd_binds
(stg_binds2, cost_centre_info) (stg_binds2, cost_centre_info)
......
...@@ -90,7 +90,7 @@ stgMassageForProfiling dflags mod_name _us stg_binds ...@@ -90,7 +90,7 @@ stgMassageForProfiling dflags mod_name _us stg_binds
---------- ----------
do_top_rhs :: Id -> StgRhs -> MassageM StgRhs do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
do_top_rhs _ (StgRhsClosure _ _ _ _ [] do_top_rhs _ (StgRhsClosure _ _ _ _ _ []
(StgTick (ProfNote _cc False{-not tick-} _push) (StgTick (ProfNote _cc False{-not tick-} _push)
(StgConApp con args))) (StgConApp con args)))
| not (isDllConApp dflags mod_name con args) | not (isDllConApp dflags mod_name con args)
...@@ -100,7 +100,7 @@ stgMassageForProfiling dflags mod_name _us stg_binds ...@@ -100,7 +100,7 @@ stgMassageForProfiling dflags mod_name _us stg_binds
-- isDllConApp checks for LitLit args too -- isDllConApp checks for LitLit args too
= return (StgRhsCon dontCareCCS con args) = 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 = do
-- Top level CAF without a cost centre attached -- Top level CAF without a cost centre attached
-- Attach CAF cc (collect if individual CAF ccs) -- Attach CAF cc (collect if individual CAF ccs)
...@@ -119,11 +119,11 @@ stgMassageForProfiling dflags mod_name _us stg_binds ...@@ -119,11 +119,11 @@ stgMassageForProfiling dflags mod_name _us stg_binds
else else
return all_cafs_ccs return all_cafs_ccs
body' <- do_expr body 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 = 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) do_top_rhs _ (StgRhsCon _ con args)
-- Top-level (static) data is not counted in heap -- Top-level (static) data is not counted in heap
...@@ -155,10 +155,10 @@ stgMassageForProfiling dflags mod_name _us stg_binds ...@@ -155,10 +155,10 @@ stgMassageForProfiling dflags mod_name _us stg_binds
expr' <- do_expr expr expr' <- do_expr expr
return (StgTick ti 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 expr' <- do_expr expr
alts' <- mapM do_alt alts alts' <- mapM do_alt alts
return (StgCase expr' bndr alt_type alts') return (StgCase expr' fv1 fv2 bndr srt alt_type alts')
where where
do_alt (id, bs, use_mask, e) = do do_alt (id, bs, use_mask, e) = do
e' <- do_expr e e' <- do_expr e
...@@ -168,9 +168,9 @@ stgMassageForProfiling dflags mod_name _us stg_binds ...@@ -168,9 +168,9 @@ stgMassageForProfiling dflags mod_name _us stg_binds
(b,e) <- do_let b e (b,e) <- do_let b e
return (StgLet 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 (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) do_expr other = pprPanic "SCCfinal.do_expr" (ppr other)
...@@ -200,15 +200,15 @@ stgMassageForProfiling dflags mod_name _us stg_binds ...@@ -200,15 +200,15 @@ stgMassageForProfiling dflags mod_name _us stg_binds
-- allocation of the constructor to the wrong place (XXX) -- allocation of the constructor to the wrong place (XXX)
-- We should really attach (PushCC cc CurrentCCS) to the rhs, -- We should really attach (PushCC cc CurrentCCS) to the rhs,
-- but need to reinstate PushCC for that. -- 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) (StgTick (ProfNote cc False{-not tick-} _push)
(StgConApp con args))) (StgConApp con args)))
= do collectCC cc = do collectCC cc
return (StgRhsCon currentCCS con args) 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 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) do_rhs (StgRhsCon _ con args)
= return (StgRhsCon currentCCS con args) = return (StgRhsCon currentCCS con args)
......
...@@ -127,7 +127,7 @@ statRhs :: Bool -> (Id, StgRhs) -> StatEnv ...@@ -127,7 +127,7 @@ statRhs :: Bool -> (Id, StgRhs) -> StatEnv
statRhs top (_, StgRhsCon _ _ _) statRhs top (_, StgRhsCon _ _ _)
= countOne (ConstructorBinds top) = countOne (ConstructorBinds top)
statRhs top (_, StgRhsClosure _ _ fv u _ body) statRhs top (_, StgRhsClosure _ _ fv u _ _ body)
= statExpr body `combineSE` = statExpr body `combineSE`
countN FreeVariables (length fv) `combineSE` countN FreeVariables (length fv) `combineSE`
countOne ( countOne (
...@@ -153,7 +153,7 @@ statExpr (StgConApp _ _) = countOne ConstructorApps ...@@ -153,7 +153,7 @@ statExpr (StgConApp _ _) = countOne ConstructorApps
statExpr (StgOpApp _ _ _) = countOne PrimitiveApps statExpr (StgOpApp _ _ _) = countOne PrimitiveApps
statExpr (StgTick _ e) = statExpr e statExpr (StgTick _ e) = statExpr e
statExpr (StgLetNoEscape binds body) statExpr (StgLetNoEscape _ _ binds body)
= statBinding False{-not top-level-} binds `combineSE` = statBinding False{-not top-level-} binds `combineSE`
statExpr body `combineSE` statExpr body `combineSE`
countOne LetNoEscapes countOne LetNoEscapes
...@@ -162,7 +162,7 @@ statExpr (StgLet binds body) ...@@ -162,7 +162,7 @@ statExpr (StgLet binds body)
= statBinding False{-not top-level-} binds `combineSE` = statBinding False{-not top-level-} binds `combineSE`
statExpr body statExpr body
statExpr (StgCase expr _ _ alts) statExpr (StgCase expr _ _ _ _ _ alts)
= statExpr expr `combineSE` = statExpr expr `combineSE`
stat_alts alts `combineSE` stat_alts alts `combineSE`
countOne StgCases countOne StgCases
......
...@@ -42,6 +42,7 @@ import MkId (realWorldPrimId) ...@@ -42,6 +42,7 @@ import MkId (realWorldPrimId)
import Type import Type
import TysWiredIn import TysWiredIn
import DataCon import DataCon
import VarSet
import OccName import OccName
import Name import Name
import Util import Util
...@@ -73,9 +74,9 @@ unariseBinding us rho bind = case bind of ...@@ -73,9 +74,9 @@ unariseBinding us rho bind = case bind of
unariseRhs :: UniqSupply -> UnariseEnv -> StgRhs -> StgRhs unariseRhs :: UniqSupply -> UnariseEnv -> StgRhs -> StgRhs
unariseRhs us rho rhs = case rhs of 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 -> 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 where (us', rho', args') = unariseIdBinders us rho args
StgRhsCon ccs con args StgRhsCon ccs con args
-> StgRhsCon ccs con (unariseArgs rho args) -> StgRhsCon ccs con (unariseArgs rho args)
...@@ -110,8 +111,10 @@ unariseExpr us rho (StgLam xs e) ...@@ -110,8 +111,10 @@ unariseExpr us rho (StgLam xs e)
where where
(us', rho', xs') = unariseIdBinders us rho xs (us', rho', xs') = unariseIdBinders us rho xs
unariseExpr us rho (StgCase e bndr alt_ty alts) unariseExpr us rho (StgCase e case_lives alts_lives bndr srt alt_ty alts)
= StgCase (unariseExpr us1 rho e) bndr alt_ty alts' = StgCase (unariseExpr us1 rho e) (unariseLives rho case_lives)
(unariseLives rho alts_lives) bndr (unariseSRT rho srt)
alt_ty alts'
where where
(us1, us2) = splitUniqSupply us (us1, us2) = splitUniqSupply us
alts' = unariseAlts us2 rho alt_ty bndr alts alts' = unariseAlts us2 rho alt_ty bndr alts
...@@ -121,8 +124,9 @@ unariseExpr us rho (StgLet bind e) ...@@ -121,8 +124,9 @@ unariseExpr us rho (StgLet bind e)
where where
(us1, us2) = splitUniqSupply us (us1, us2) = splitUniqSupply us
unariseExpr us rho (StgLetNoEscape bind e) unariseExpr us rho (StgLetNoEscape live_in_let live_in_bind bind e)
= StgLetNoEscape (unariseBinding us1 rho bind) (unariseExpr us2 rho e) = StgLetNoEscape (unariseLives rho live_in_let) (unariseLives rho live_in_bind)
(unariseBinding us1 rho bind) (unariseExpr us2 rho e)
where where
(us1, us2) = splitUniqSupply us (us1, us2) = splitUniqSupply us
...@@ -157,6 +161,13 @@ unariseAlt us rho (con, xs, uses, e) ...@@ -157,6 +161,13 @@ unariseAlt us rho (con, xs, uses, e)
(us', rho', xs', uses') = unariseUsedIdBinders us rho xs uses (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 :: UnariseEnv -> [StgArg] -> [StgArg]
unariseArgs rho = concatMap (unariseArg rho) unariseArgs rho = concatMap (unariseArg rho)
...@@ -201,3 +212,6 @@ unariseIdBinder us rho x = case repType (idType x) of ...@@ -201,3 +212,6 @@ unariseIdBinder us rho x = case repType (idType x) of
unboxedTupleBindersFrom :: UniqSupply -> Id -> [UnaryType] -> [Id] unboxedTupleBindersFrom :: UniqSupply -> Id -> [UnaryType] -> [Id]
unboxedTupleBindersFrom us x tys = zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys unboxedTupleBindersFrom us x tys = zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys
where fs = occNameFS (getOccName x) 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) ...@@ -50,10 +50,11 @@ import Control.Monad (liftM, ap)
-- Note [Live vs free] -- Note [Live vs free]
-- ~~~~~~~~~~~~~~~~~~~ -- ~~~~~~~~~~~~~~~~~~~
-- --
-- The two are not the same. Liveness is an operational property rather -- The actual Stg datatype is decorated with live variable information, as well
-- than a semantic one. A variable is live at a particular execution -- as free variable information. The two are not the same. Liveness is an
-- point if it can be referred to directly again. In particular, a dead -- operational property rather than a semantic one. A variable is live at a
-- variable's stack slot (if it has one): -- 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 -- - should be stubbed to avoid space leaks, and
-- - may be reused for something else. -- - may be reused for something else.
...@@ -87,7 +88,8 @@ import Control.Monad (liftM, ap) ...@@ -87,7 +88,8 @@ import Control.Monad (liftM, ap)
-- Note [Collecting live CAF info] -- 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 -- A top-level Id has CafInfo, which is
-- --
...@@ -106,6 +108,24 @@ import Control.Monad (liftM, ap) ...@@ -106,6 +108,24 @@ import Control.Monad (liftM, ap)
-- the actual nested SRTs, and replaces the lists of Ids with (offset,length) -- the actual nested SRTs, and replaces the lists of Ids with (offset,length)
-- pairs. -- 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] -- Note [What is a non-escaping let]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- --
...@@ -166,9 +186,9 @@ import Control.Monad (liftM, ap) ...@@ -166,9 +186,9 @@ import Control.Monad (liftM, ap)
-- Setting variable info: top-level, binds, RHSs -- Setting variable info: top-level, binds, RHSs
-- -------------------------------------------------------------- -- --------------------------------------------------------------
coreToStg :: DynFlags -> Module -> CoreProgram -> [StgBinding] coreToStg :: DynFlags -> Module -> CoreProgram -> IO [StgBinding]
coreToStg dflags this_mod pgm coreToStg dflags this_mod pgm
= pgm' = return pgm'
where (_, _, pgm') = coreTopBindsToStg dflags this_mod emptyVarEnv pgm where (_, _, pgm') = coreTopBindsToStg dflags this_mod emptyVarEnv pgm
coreExprToStg :: CoreExpr -> StgExpr coreExprToStg :: CoreExpr -> StgExpr
...@@ -265,8 +285,9 @@ coreToTopStgRhs ...@@ -265,8 +285,9 @@ coreToTopStgRhs
coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs) coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs)
= do { (new_rhs, rhs_fvs, _) <- coreToStgExpr 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 stg_arity = stgRhsArity stg_rhs
; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs, ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
rhs_fvs) } rhs_fvs) }
...@@ -293,7 +314,7 @@ coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs) ...@@ -293,7 +314,7 @@ coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs)
text "STG arity:" <+> ppr stg_arity] text "STG arity:" <+> ppr stg_arity]
mkTopStgRhs :: DynFlags -> Module -> FreeVarsInfo mkTopStgRhs :: DynFlags -> Module -> FreeVarsInfo
-> Id -> StgBinderInfo -> StgExpr -> SRT -> Id -> StgBinderInfo -> StgExpr
-> StgRhs -> StgRhs
mkTopStgRhs dflags this_mod = mkStgRhs' con_updateable mkTopStgRhs dflags this_mod = mkStgRhs' con_updateable
...@@ -393,12 +414,23 @@ coreToStgExpr (Case scrut bndr _ alts) = do ...@@ -393,12 +414,23 @@ coreToStgExpr (Case scrut bndr _ alts) = do
alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs
alts_escs_wo_bndr = alts_escs `delVarSet` bndr alts_escs_wo_bndr = alts_escs `delVarSet` bndr
alts_lv_info <- freeVarsToLiveVars alts_fvs_wo_bndr
-- We tell the scrutinee that everything -- We tell the scrutinee that everything
-- live in the alts is live in it, too. -- 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 ( 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, scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
-- You might think we should have scrut_escs, not -- You might think we should have scrut_escs, not
...@@ -650,29 +682,39 @@ coreToStgLet ...@@ -650,29 +682,39 @@ coreToStgLet
-- is among the escaping vars -- is among the escaping vars
coreToStgLet let_no_escape bind body = do coreToStgLet let_no_escape bind body = do
(bind2, bind_fvs, bind_escs, (bind2, bind_fvs, bind_escs, bind_lvs,
body2, body_fvs, body_escs) body2, body_fvs, body_escs, body_lvs)
<- mfix $ \ ~(_, _, _, _, rec_body_fvs, _) -> do <- mfix $ \ ~(_, _, _, _, _, rec_body_fvs, _, _) -> do
( bind2, bind_fvs, bind_escs, env_ext) -- Do the bindings, setting live_in_cont to empty if
<- vars_bind rec_body_fvs bind -- 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 -- Do the body
extendVarEnvLne env_ext $ do extendVarEnvLne env_ext $ do
(body2, body_fvs, body_escs) <- coreToStgExpr body (body2, body_fvs, body_escs) <- coreToStgExpr body
body_lv_info <- freeVarsToLiveVars body_fvs
return (bind2, bind_fvs, bind_escs, return (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
body2, body_fvs, body_escs) body2, body_fvs, body_escs, getLiveVars body_lv_info)
-- Compute the new let-expression -- Compute the new let-expression
let 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 | otherwise = StgLet bind2 body2
free_in_whole_let free_in_whole_let
= binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs) = 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 real_bind_escs = if let_no_escape then
bind_escs bind_escs
else else
...@@ -705,43 +747,49 @@ coreToStgLet let_no_escape bind body = do ...@@ -705,43 +747,49 @@ coreToStgLet let_no_escape bind body = do
set_of_binders = mkVarSet binders set_of_binders = mkVarSet binders
binders = bindersOf bind binders = bindersOf bind
mk_binding binder rhs mk_binding bind_lv_info binder rhs
= (binder, LetBound NestedLet (manifestArity 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 vars_bind :: FreeVarsInfo -- Free var info for body of binding
-> CoreBind -> CoreBind
-> LneM (StgBinding, -> LneM (StgBinding,
FreeVarsInfo, FreeVarsInfo,
EscVarsSet, -- free vars; escapee vars EscVarsSet, -- free vars; escapee vars
LiveInfo, -- Vars and CAFs live in binding
[(Id, HowBound)]) -- extension to environment [(Id, HowBound)]) -- extension to environment
vars_bind body_fvs (NonRec binder rhs) = do 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 let
env_ext_item = mk_binding binder rhs env_ext_item = mk_binding bind_lv_info binder rhs
return (StgNonRec binder rhs2, 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) vars_bind body_fvs (Rec pairs)
= mfix $ \ ~(_, rec_rhs_fvs, _, _) -> = mfix $ \ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
let let
rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs