X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplEnv.lhs;h=a2e06a0bf78a74876940a8ede7aa001e300fa530;hp=3556b7eae377bbf71f3a2ee97f58eaf6f4a17dc8;hb=e79c9ce01d0ce4412bd4bcd99c8c728a6a2ec569;hpb=bb394e57361d9910b05f1145cbc894d33759d2a6 diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index 3556b7e..a2e06a0 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -5,8 +5,8 @@ \begin{code} module SimplEnv ( - InId, InBind, InExpr, InAlt, InArg, InType, InBinder, - OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder, + InId, InBind, InExpr, InAlt, InArg, InType, InBndr, + OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr, InCoercion, OutCoercion, -- The simplifier mode @@ -19,52 +19,47 @@ module SimplEnv ( setEnclosingCC, getEnclosingCC, -- Environments - SimplEnv, mkSimplEnv, extendIdSubst, extendTvSubst, + SimplEnv(..), pprSimplEnv, -- Temp not abstract + mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, zapSubstEnv, setSubstEnv, getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds, - getRules, + getSimplRules, - SimplSR(..), mkContEx, substId, + SimplSR(..), mkContEx, substId, lookupRecBndr, simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, - simplBinder, simplBinders, addLetIdInfo, - substExpr, substTy, + simplBinder, simplBinders, addBndrRules, + substExpr, substWorker, substTy, -- Floats - FloatsWith, FloatsWithExpr, - Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats, - allLifted, wrapFloats, floatBinds, - addAuxiliaryBind, + Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats, + wrapFloats, floatBinds, setFloats, zapFloats, addRecFloats, + doFloatFromRhs, getFloats ) where #include "HsVersions.h" -import SimplMonad -import Id ( Id, idType, idOccInfo, idUnfolding, setIdUnfolding ) -import IdInfo ( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecInfo, - arityInfo, setArityInfo, workerInfo, setWorkerInfo, - unfoldingInfo, setUnfoldingInfo, isEmptySpecInfo, - unknownArity, workerExists - ) +import SimplMonad +import IdInfo import CoreSyn -import Rules ( RuleBase ) -import CoreUtils ( needsCaseBinding ) -import CostCentre ( CostCentreStack, subsumedCCS ) -import Var +import CoreUtils +import CostCentre +import Var import VarEnv -import VarSet ( isEmptyVarSet ) +import VarSet import OrdList - +import Id import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substWorker ) import qualified Type ( substTy, substTyVarBndr ) - -import Type ( Type, TvSubst(..), TvSubstEnv, composeTvSubst, - isUnLiftedType, seqType, tyVarsOfType ) -import Coercion ( Coercion ) -import BasicTypes ( OccInfo(..), isFragileOcc ) -import DynFlags ( SimplifierMode(..) ) -import Util ( mapAccumL ) +import Type hiding ( substTy, substTyVarBndr ) +import Coercion +import BasicTypes +import DynFlags +import MonadUtils import Outputable +import FastString + +import Data.List \end{code} %************************************************************************ @@ -74,7 +69,7 @@ import Outputable %************************************************************************ \begin{code} -type InBinder = CoreBndr +type InBndr = CoreBndr type InId = Id -- Not yet cloned type InType = Type -- Ditto type InBind = CoreBind @@ -83,7 +78,7 @@ type InAlt = CoreAlt type InArg = CoreArg type InCoercion = Coercion -type OutBinder = CoreBndr +type OutBndr = CoreBndr type OutId = Id -- Cloned type OutTyVar = TyVar -- Cloned type OutType = Type -- Cloned @@ -108,26 +103,44 @@ data SimplEnv seChkr :: SwitchChecker, seCC :: CostCentreStack, -- The enclosing CCS (when profiling) - -- Rules from other modules - seExtRules :: RuleBase, - -- The current set of in-scope variables -- They are all OutVars, and all bound in this module seInScope :: InScopeSet, -- OutVars only + -- Includes all variables bound by seFloats + seFloats :: Floats, + -- See Note [Simplifier floats] -- The current substitution seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType seIdSubst :: SimplIdSubst -- InId |--> OutExpr + } +pprSimplEnv :: SimplEnv -> SDoc +-- Used for debugging; selective +pprSimplEnv env + = vcat [ptext (sLit "TvSubst:") <+> ppr (seTvSubst env), + ptext (sLit "IdSubst:") <+> ppr (seIdSubst env) ] + type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr + -- See Note [Extending the Subst] in CoreSubst data SimplSR = DoneEx OutExpr -- Completed term - | DoneId OutId OccInfo -- Completed term variable, with occurrence info + | DoneId OutId -- Completed term variable | ContEx TvSubstEnv -- A suspended substitution SimplIdSubst InExpr + +instance Outputable SimplSR where + ppr (DoneEx e) = ptext (sLit "DoneEx") <+> ppr e + ppr (DoneId v) = ptext (sLit "DoneId") <+> ppr v + ppr (ContEx _tv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-, + ppr (filter_env tv), ppr (filter_env id) -}] + -- where + -- fvs = exprFreeVars e + -- filter_env env = filterVarEnv_Directly keep env + -- keep uniq _ = uniq `elemUFM_Directly` fvs \end{code} @@ -151,11 +164,6 @@ seIdSubst: a77 -> a77 from the substitution, when we decide not to clone a77, but it's quite legitimate to put the mapping in the substitution anyway. - - Indeed, we do so when we want to pass fragile OccInfo to the - occurrences of the variable; we add a substitution - x77 -> DoneId x77 occ - to record x's occurrence information.] Furthermore, consider let x = case k of I# x77 -> ... in @@ -168,12 +176,9 @@ seIdSubst: Of course, the substitution *must* applied! Things in its domain simply aren't necessarily bound in the result. -* substId adds a binding (DoneId new_id occ) to the substitution if - EITHER the Id's unique has changed - OR the Id has interesting occurrence information - So in effect you can only get to interesting occurrence information - by looking up the *old* Id; it's not really attached to the new id - at all. +* substId adds a binding (DoneId new_id) to the substitution if + the Id's unique has changed + Note, though that the substitution isn't necessarily extended if the type changes. Why not? Because of the next point: @@ -201,11 +206,11 @@ seIdSubst: \begin{code} -mkSimplEnv :: SimplifierMode -> SwitchChecker -> RuleBase -> SimplEnv -mkSimplEnv mode switches rules +mkSimplEnv :: SimplifierMode -> SwitchChecker -> SimplEnv +mkSimplEnv mode switches = SimplEnv { seChkr = switches, seCC = subsumedCCS, seMode = mode, seInScope = emptyInScopeSet, - seExtRules = rules, + seFloats = emptyFloats, seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv } -- The top level "enclosing CC" is "SUBSUMED". @@ -244,7 +249,16 @@ setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv setInScopeSet env in_scope = env {seInScope = in_scope} setInScope :: SimplEnv -> SimplEnv -> SimplEnv -setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_scope) +-- Set the in-scope set, and *zap* the floats +setInScope env env_with_scope + = env { seInScope = seInScope env_with_scope, + seFloats = emptyFloats } + +setFloats :: SimplEnv -> SimplEnv -> SimplEnv +-- Set the in-scope set *and* the floats +setFloats env env_with_floats + = env { seInScope = seInScope env_with_floats, + seFloats = seFloats env_with_floats } addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv -- The new Ids are guaranteed to be freshly allocated @@ -254,12 +268,15 @@ addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) v -- Why delete? Consider -- let x = a*b in (x, \x -> x+3) -- We add [x |-> a*b] to the substitution, but we must - -- *delete* it from the substitution when going inside + -- _delete_ it from the substitution when going inside -- the (\x -> ...)! -modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv -modifyInScope env@(SimplEnv {seInScope = in_scope}) v v' - = env {seInScope = modifyInScopeSet in_scope v v'} +modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv +-- The variable should already be in scope, but +-- replace the existing version with this new one +-- which has more information +modifyInScope env@(SimplEnv {seInScope = in_scope}) v + = env {seInScope = extendInScopeSet in_scope v} --------------------- zapSubstEnv :: SimplEnv -> SimplEnv @@ -270,14 +287,153 @@ setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids } mkContEx :: SimplEnv -> InExpr -> SimplSR mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e +\end{code} -isEmptySimplSubst :: SimplEnv -> Bool -isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) - = isEmptyVarEnv tvs && isEmptyVarEnv ids ---------------------- -getRules :: SimplEnv -> RuleBase -getRules = seExtRules + +%************************************************************************ +%* * +\subsection{Floats} +%* * +%************************************************************************ + +Note [Simplifier floats] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The Floats is a bunch of bindings, classified by a FloatFlag. + + NonRec x (y:ys) FltLifted + Rec [(x,rhs)] FltLifted + + NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n + + NonRec x# (a /# b) FltCareful + NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge + NonRec x# (f y) FltCareful -- Unboxed binding: might fail or diverge + -- (where f :: Int -> Int#) + +\begin{code} +data Floats = Floats (OrdList OutBind) FloatFlag + -- See Note [Simplifier floats] + +data FloatFlag + = FltLifted -- All bindings are lifted and lazy + -- Hence ok to float to top level, or recursive + + | FltOkSpec -- All bindings are FltLifted *or* + -- strict (perhaps because unlifted, + -- perhaps because of a strict binder), + -- *and* ok-for-speculation + -- Hence ok to float out of the RHS + -- of a lazy non-recursive let binding + -- (but not to top level, or into a rec group) + + | FltCareful -- At least one binding is strict (or unlifted) + -- and not guaranteed cheap + -- Do not float these bindings out of a lazy let + +instance Outputable Floats where + ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds) + +instance Outputable FloatFlag where + ppr FltLifted = ptext (sLit "FltLifted") + ppr FltOkSpec = ptext (sLit "FltOkSpec") + ppr FltCareful = ptext (sLit "FltCareful") + +andFF :: FloatFlag -> FloatFlag -> FloatFlag +andFF FltCareful _ = FltCareful +andFF FltOkSpec FltCareful = FltCareful +andFF FltOkSpec _ = FltOkSpec +andFF FltLifted flt = flt + +classifyFF :: CoreBind -> FloatFlag +classifyFF (Rec _) = FltLifted +classifyFF (NonRec bndr rhs) + | not (isStrictId bndr) = FltLifted + | exprOkForSpeculation rhs = FltOkSpec + | otherwise = FltCareful + +doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool +doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff}) + = not (isNilOL fs) && want_to_float && can_float + where + want_to_float = isTopLevel lvl || exprIsCheap rhs + can_float = case ff of + FltLifted -> True + FltOkSpec -> isNotTopLevel lvl && isNonRec rec + FltCareful -> isNotTopLevel lvl && isNonRec rec && str +\end{code} + + +\begin{code} +emptyFloats :: Floats +emptyFloats = Floats nilOL FltLifted + +unitFloat :: OutBind -> Floats +-- A single-binding float +unitFloat bind = Floats (unitOL bind) (classifyFF bind) + +addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv +-- Add a non-recursive binding and extend the in-scope set +-- The latter is important; the binder may already be in the +-- in-scope set (although it might also have been created with newId) +-- but it may now have more IdInfo +addNonRec env id rhs + = env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs), + seInScope = extendInScopeSet (seInScope env) id } + +extendFloats :: SimplEnv -> OutBind -> SimplEnv +-- Add these bindings to the floats, and extend the in-scope env too +extendFloats env bind + = env { seFloats = seFloats env `addFlts` unitFloat bind, + seInScope = extendInScopeSetList (seInScope env) bndrs } + where + bndrs = bindersOf bind + +addFloats :: SimplEnv -> SimplEnv -> SimplEnv +-- Add the floats for env2 to env1; +-- *plus* the in-scope set for env2, which is bigger +-- than that for env1 +addFloats env1 env2 + = env1 {seFloats = seFloats env1 `addFlts` seFloats env2, + seInScope = seInScope env2 } + +addFlts :: Floats -> Floats -> Floats +addFlts (Floats bs1 l1) (Floats bs2 l2) + = Floats (bs1 `appOL` bs2) (l1 `andFF` l2) + +zapFloats :: SimplEnv -> SimplEnv +zapFloats env = env { seFloats = emptyFloats } + +addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv +-- Flattens the floats from env2 into a single Rec group, +-- prepends the floats from env1, and puts the result back in env2 +-- This is all very specific to the way recursive bindings are +-- handled; see Simplify.simplRecBind +addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff}) + = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) ) + env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))} + +wrapFloats :: SimplEnv -> OutExpr -> OutExpr +wrapFloats env expr = wrapFlts (seFloats env) expr + +wrapFlts :: Floats -> OutExpr -> OutExpr +-- Wrap the floats around the expression, using case-binding where necessary +wrapFlts (Floats bs _) body = foldrOL wrap body bs + where + wrap (Rec prs) body = Let (Rec prs) body + wrap (NonRec b r) body = bindNonRec b r body + +getFloats :: SimplEnv -> [CoreBind] +getFloats (SimplEnv {seFloats = Floats bs _}) = fromOL bs + +isEmptyFloats :: SimplEnv -> Bool +isEmptyFloats env = isEmptyFlts (seFloats env) + +isEmptyFlts :: Floats -> Bool +isEmptyFlts (Floats bs _) = isNilOL bs + +floatBinds :: Floats -> [OutBind] +floatBinds (Floats bs _) = fromOL bs \end{code} @@ -287,31 +443,46 @@ getRules = seExtRules %* * %************************************************************************ +Note [Global Ids in the substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We look up even a global (eg imported) Id in the substitution. Consider + case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... } +The binder-swap in the occurence analyser will add a binding +for a LocalId version of g (with the same unique though): + case X.g_34 of b { (a,b) -> let g_34 = b in + ... case X.g_34 of { (p,q) -> ...} ... } +So we want to look up the inner X.g_34 in the substitution, where we'll +find that it has been substituted by b. (Or conceivably cloned.) \begin{code} -substId :: SimplEnv -> Id -> SimplSR +substId :: SimplEnv -> InId -> SimplSR +-- Returns DoneEx only on a non-Var expression substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v - | not (isLocalId v) - = DoneId v NoOccInfo - | otherwise -- A local Id - = case lookupVarEnv ids v of - Just (DoneId v occ) -> DoneId (refine v) occ - Just res -> res - Nothing -> let v' = refine v - in DoneId v' (idOccInfo v') - -- We don't put LoopBreakers in the substitution (unless then need - -- to be cloned for name-clash rasons), so the idOccInfo is - -- very important! If isFragileOcc returned True for - -- loop breakers we could avoid this call, but at the expense - -- of adding more to the substitution, and building new Ids - -- a bit more often than really necessary + = case lookupVarEnv ids v of -- Note [Global Ids in the substitution] + Nothing -> DoneId (refine in_scope v) + Just (DoneId v) -> DoneId (refine in_scope v) + Just (DoneEx (Var v)) -> DoneId (refine in_scope v) + Just res -> res -- DoneEx non-var, or ContEx where + -- Get the most up-to-date thing from the in-scope set -- Even though it isn't in the substitution, it may be in - -- the in-scope set better IdInfo - refine v = case lookupInScope in_scope v of - Just v' -> v' - Nothing -> WARN( True, ppr v ) v -- This is an error! + -- the in-scope set with better IdInfo +refine :: InScopeSet -> Var -> Var +refine in_scope v + | isLocalId v = case lookupInScope in_scope v of + Just v' -> v' + Nothing -> WARN( True, ppr v ) v -- This is an error! + | otherwise = v + +lookupRecBndr :: SimplEnv -> InId -> OutId +-- Look up an Id which has been put into the envt by simplRecBndrs, +-- but where we have not yet done its RHS +lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v + = case lookupVarEnv ids v of + Just (DoneId v) -> v + Just _ -> pprPanic "lookupRecBndr" (ppr v) + Nothing -> refine in_scope v \end{code} @@ -326,12 +497,12 @@ These functions are in the monad only so that they can be made strict via seq. \begin{code} simplBinders, simplLamBndrs - :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder]) -simplBinders env bndrs = mapAccumLSmpl simplBinder env bndrs -simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr env bndrs + :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) +simplBinders env bndrs = mapAccumLM simplBinder env bndrs +simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs ------------- -simplBinder :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder) +simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) -- Used for lambda and case-bound variables -- Clone Id if necessary, substitute type -- Return with IdInfo already substituted, but (fragile) occurrence info zapped @@ -346,59 +517,77 @@ simplBinder env bndr ------------- simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var) -- Used for lambda binders. These sometimes have unfoldings added by --- the worker/wrapper pass that must be preserved, becuase they can't +-- the worker/wrapper pass that must be preserved, because they can't -- be reconstructed from context. For example: -- f x = case x of (a,b) -> fw a b x -- fw a b x{=(a,b)} = ... -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise. simplLamBndr env bndr - | not (isId bndr && hasSomeUnfolding old_unf) = simplBinder env bndr -- Normal case - | otherwise = seqId id2 `seq` return (env', id2) + | isId bndr && hasSomeUnfolding old_unf = seqId id2 `seq` return (env2, id2) -- Special case + | otherwise = simplBinder env bndr -- Normal case where old_unf = idUnfolding bndr - (env', id1) = substIdBndr env bndr - id2 = id1 `setIdUnfolding` substUnfolding env old_unf + (env1, id1) = substIdBndr env bndr + id2 = id1 `setIdUnfolding` substUnfolding env old_unf + env2 = modifyInScope env1 id2 --------------- -substIdBndr :: SimplEnv -> Id -- Substitition and Id to transform - -> (SimplEnv, Id) -- Transformed pair +--------------- +simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) +-- A non-recursive let binder +simplNonRecBndr env id + = do { let (env1, id1) = substIdBndr env id + ; seqId id1 `seq` return (env1, id1) } --- Returns with: --- * Unique changed if necessary +--------------- +simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv +-- Recursive let binders +simplRecBndrs env@(SimplEnv {}) ids + = do { let (env1, ids1) = mapAccumL substIdBndr env ids + ; seqIds ids1 `seq` return env1 } + +--------------- +substIdBndr :: SimplEnv + -> InBndr -- Env and binder to transform + -> (SimplEnv, OutBndr) +-- Clone Id if necessary, substitute its type +-- Return an Id with its -- * Type substituted --- * Unfolding zapped --- * Rules, worker, lbvar info all substituted --- * Fragile occurrence info zapped --- * The in-scope set extended with the returned Id --- * The substitution extended with a DoneId if unique changed --- In this case, the var in the DoneId is the same as the --- var returned - -substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst}) - old_id - = (env { seInScope = in_scope `extendInScopeSet` new_id, +-- * UnfoldingInfo, Rules, WorkerInfo zapped +-- * Fragile OccInfo (only) zapped: Note [Robust OccInfo] +-- * Robust info, retained especially arity and demand info, +-- so that they are available to occurrences that occur in an +-- earlier binding of a letrec +-- +-- For the robust info, see Note [Arity robustness] +-- +-- Augment the substitution if the unique changed +-- Extend the in-scope set with the new Id +-- +-- Similar to CoreSubst.substIdBndr, except that +-- the type of id_subst differs +-- all fragile info is zapped + +substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) + old_id + = (env { seInScope = in_scope `extendInScopeSet` new_id, seIdSubst = new_subst }, new_id) where - -- id1 is cloned if necessary - id1 = uniqAway in_scope old_id - - -- id2 has its type zapped - id2 = substIdType env id1 - - -- new_id has the final IdInfo - subst = mkCoreSubst env - new_id = maybeModifyIdInfo (substIdInfo subst (idInfo old_id)) id2 + id1 = uniqAway in_scope old_id + id2 = substIdType env id1 + new_id = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding + -- and fragile OccInfo - -- Extend the substitution if the unique has changed + -- Extend the substitution if the unique has changed, + -- or there's some useful occurrence information -- See the notes with substTyVarBndr for the delSubstEnv new_subst | new_id /= old_id - = extendVarEnv id_subst old_id (DoneId new_id (idOccInfo old_id)) + = extendVarEnv id_subst old_id (DoneId new_id) | otherwise = delVarEnv id_subst old_id \end{code} - \begin{code} +------------------------------------ seqTyVar :: TyVar -> () seqTyVar b = b `seq` () @@ -413,75 +602,11 @@ seqIds (id:ids) = seqId id `seq` seqIds ids \end{code} -%************************************************************************ -%* * - Let bindings -%* * -%************************************************************************ - -Simplifying let binders +Note [Arity robustness] ~~~~~~~~~~~~~~~~~~~~~~~ -Rename the binders if necessary, - -\begin{code} -simplNonRecBndr :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder) -simplNonRecBndr env id - = do { let (env1, id1) = substLetIdBndr env id - ; seqId id1 `seq` return (env1, id1) } - ---------------- -simplRecBndrs :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder]) -simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids - = do { let (env1, ids1) = mapAccumL substLetIdBndr env ids - ; seqIds ids1 `seq` return (env1, ids1) } - ---------------- -substLetIdBndr :: SimplEnv -> InBinder -- Env and binder to transform - -> (SimplEnv, OutBinder) --- C.f. CoreSubst.substIdBndr --- Clone Id if necessary, substitute its type --- Return an Id with completely zapped IdInfo --- [addLetIdInfo, below, will restore its IdInfo] --- Augment the subtitution --- if the unique changed, *or* --- if there's interesting occurrence info - -substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id - = (env { seInScope = in_scope `extendInScopeSet` new_id, - seIdSubst = new_subst }, new_id) - where - id1 = uniqAway in_scope old_id - id2 = substIdType env id1 - new_id = setIdInfo id2 vanillaIdInfo - - -- Extend the substitution if the unique has changed, - -- or there's some useful occurrence information - -- See the notes with substTyVarBndr for the delSubstEnv - occ_info = occInfo (idInfo old_id) - new_subst | new_id /= old_id || isFragileOcc occ_info - = extendVarEnv id_subst old_id (DoneId new_id occ_info) - | otherwise - = delVarEnv id_subst old_id -\end{code} - -Add IdInfo back onto a let-bound Id -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must transfer the IdInfo of the original binder to the new binder. -This is crucial, to preserve - strictness - rules - worker info -etc. To do this we must apply the current substitution, -which incorporates earlier substitutions in this very letrec group. - -NB 1. We do this *before* processing the RHS of the binder, so that -its substituted rules are visible in its own RHS. -This is important. Manuel found cases where he really, really -wanted a RULE for a recursive function to apply in that function's -own right-hand side. - -NB 2: ARITY. We *do* transfer the arity. This is important, so that -the arity of an Id is visible in its own RHS. For example: +We *do* transfer the arity from from the in_id of a let binding to the +out_id. This is important, so that the arity of an Id is visible in +its own RHS. For example: f = \x. ....g (\y. f y).... We can eta-reduce the arg to g, becuase f is a value. But that needs to be visible. @@ -495,7 +620,7 @@ Can we eta-expand f? Only if we see that f has arity 1, and then we take advantage of the 'state hack' on the result of (f y) :: State# -> (State#, Int) to expand the arity one more. -There is a disadvantage though. Making the arity visible in the RHA +There is a disadvantage though. Making the arity visible in the RHS allows us to eta-reduce f = \x -> f x to @@ -505,68 +630,42 @@ I'm not worried about it. Another idea is to ensure that f's arity never decreases; its arity started as 1, and we should never eta-reduce below that. -NB 3: OccInfo. It's important that we *do* transer the loop-breaker -OccInfo, because that's what stops the Id getting inlined infinitely, -in the body of the letrec. -NB 4: does no harm for non-recursive bindings +Note [Robust OccInfo] +~~~~~~~~~~~~~~~~~~~~~ +It's important that we *do* retain the loop-breaker OccInfo, because +that's what stops the Id getting inlined infinitely, in the body of +the letrec. + + +Note [Rules in a letrec] +~~~~~~~~~~~~~~~~~~~~~~~~ +After creating fresh binders for the binders of a letrec, we +substitute the RULES and add them back onto the binders; this is done +*before* processing any of the RHSs. This is important. Manuel found +cases where he really, really wanted a RULE for a recursive function +to apply in that function's own right-hand side. + +See Note [Loop breaking and RULES] in OccAnal. -NB 5: we can't do the addLetIdInfo part before *all* the RHSs because - rec { f = g - h = ... - RULE h Int = f - } -Here, we'll do postInlineUnconditionally on f, and we must "see" that -when substituting in h's RULE. \begin{code} -addLetIdInfo :: SimplEnv -> InBinder -> OutBinder -> (SimplEnv, OutBinder) -addLetIdInfo env in_id out_id - = (modifyInScope env out_id final_id, final_id) - where - final_id = out_id `setIdInfo` new_info - subst = mkCoreSubst env - old_info = idInfo in_id - new_info = case substIdInfo subst old_info of - Nothing -> old_info - Just new_info -> new_info - -substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo --- Substitute the --- rules --- worker info --- Zap the unfolding --- Keep only 'robust' OccInfo --- arity --- --- Seq'ing on the returned IdInfo is enough to cause all the --- substitutions to happen completely - -substIdInfo subst info - | nothing_to_do = Nothing - | otherwise = Just (info `setOccInfo` (if keep_occ then old_occ else NoOccInfo) - `setSpecInfo` CoreSubst.substSpec subst old_rules - `setWorkerInfo` CoreSubst.substWorker subst old_wrkr - `setUnfoldingInfo` noUnfolding) - -- setSpecInfo does a seq - -- setWorkerInfo does a seq +addBndrRules :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr) +-- Rules are added back in to to the bin +addBndrRules env in_id out_id + | isEmptySpecInfo old_rules = (env, out_id) + | otherwise = (modifyInScope env final_id, final_id) where - nothing_to_do = keep_occ && - isEmptySpecInfo old_rules && - not (workerExists old_wrkr) && - not (hasUnfolding (unfoldingInfo info)) - - keep_occ = not (isFragileOcc old_occ) - old_arity = arityInfo info - old_occ = occInfo info - old_rules = specInfo info - old_wrkr = workerInfo info + subst = mkCoreSubst env + old_rules = idSpecialisation in_id + new_rules = CoreSubst.substSpec subst out_id old_rules + final_id = out_id `setIdSpecialisation` new_rules ------------------ substIdType :: SimplEnv -> Id -> Id -substIdType env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id +substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id - | otherwise = setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty) + | otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty) -- The tyVarsOfType is cheaper than it looks -- because we cache the free tyvars of the type -- in a Note in the id's type itself @@ -574,10 +673,16 @@ substIdType env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id old_ty = idType id ------------------ -substUnfolding env NoUnfolding = NoUnfolding -substUnfolding env (OtherCon cons) = OtherCon cons +substUnfolding :: SimplEnv -> Unfolding -> Unfolding +substUnfolding _ NoUnfolding = NoUnfolding +substUnfolding _ (OtherCon cons) = OtherCon cons substUnfolding env (CompulsoryUnfolding rhs) = CompulsoryUnfolding (substExpr env rhs) substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g + +------------------ +substWorker :: SimplEnv -> WorkerInfo -> WorkerInfo +substWorker _ NoWorker = NoWorker +substWorker env wkr_info = CoreSubst.substWorker (mkCoreSubst env) wkr_info \end{code} @@ -610,90 +715,12 @@ mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env) fiddle (DoneEx e) = e - fiddle (DoneId v occ) = Var v + fiddle (DoneId v) = Var v fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e substExpr :: SimplEnv -> CoreExpr -> CoreExpr -substExpr env expr - | isEmptySimplSubst env = expr - | otherwise = CoreSubst.substExpr (mkCoreSubst env) expr +substExpr env expr = CoreSubst.substExpr (mkCoreSubst env) expr + -- Do *not* short-cut in the case of an empty substitution + -- See CoreSubst: Note [Extending the Subst] \end{code} - -%************************************************************************ -%* * -\subsection{Floats} -%* * -%************************************************************************ - -\begin{code} -type FloatsWithExpr = FloatsWith OutExpr -type FloatsWith a = (Floats, a) - -- We return something equivalent to (let b in e), but - -- in pieces to avoid the quadratic blowup when floating - -- incrementally. Comments just before simplExprB in Simplify.lhs - -data Floats = Floats (OrdList OutBind) - InScopeSet -- Environment "inside" all the floats - Bool -- True <=> All bindings are lifted - -allLifted :: Floats -> Bool -allLifted (Floats _ _ is_lifted) = is_lifted - -wrapFloats :: Floats -> OutExpr -> OutExpr -wrapFloats (Floats bs _ _) body = foldrOL Let body bs - -isEmptyFloats :: Floats -> Bool -isEmptyFloats (Floats bs _ _) = isNilOL bs - -floatBinds :: Floats -> [OutBind] -floatBinds (Floats bs _ _) = fromOL bs - -flattenFloats :: Floats -> Floats --- Flattens into a single Rec group -flattenFloats (Floats bs is is_lifted) - = ASSERT2( is_lifted, ppr (fromOL bs) ) - Floats (unitOL (Rec (flattenBinds (fromOL bs)))) is is_lifted -\end{code} - -\begin{code} -emptyFloats :: SimplEnv -> Floats -emptyFloats env = Floats nilOL (getInScope env) True - -unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats --- A single non-rec float; extend the in-scope set -unitFloat env var rhs = Floats (unitOL (NonRec var rhs)) - (extendInScopeSet (getInScope env) var) - (not (isUnLiftedType (idType var))) - -addFloats :: SimplEnv -> Floats - -> (SimplEnv -> SimplM (FloatsWith a)) - -> SimplM (FloatsWith a) -addFloats env (Floats b1 is1 l1) thing_inside - | isNilOL b1 - = thing_inside env - | otherwise - = thing_inside (setInScopeSet env is1) `thenSmpl` \ (Floats b2 is2 l2, res) -> - returnSmpl (Floats (b1 `appOL` b2) is2 (l1 && l2), res) - -addLetBind :: OutBind -> Floats -> Floats -addLetBind bind (Floats binds in_scope lifted) - = Floats (bind `consOL` binds) in_scope (lifted && is_lifted_bind bind) - -is_lifted_bind (Rec _) = True -is_lifted_bind (NonRec b r) = not (isUnLiftedType (idType b)) - --- addAuxiliaryBind * takes already-simplified things (bndr and rhs) --- * extends the in-scope env --- * assumes it's a let-bindable thing -addAuxiliaryBind :: SimplEnv -> OutBind - -> (SimplEnv -> SimplM (FloatsWith a)) - -> SimplM (FloatsWith a) - -- Extends the in-scope environment as well as wrapping the bindings -addAuxiliaryBind env bind thing_inside - = ASSERT( case bind of { NonRec b r -> not (needsCaseBinding (idType b) r) ; Rec _ -> True } ) - thing_inside (addNewInScopeIds env (bindersOf bind)) `thenSmpl` \ (floats, x) -> - returnSmpl (addLetBind bind floats, x) -\end{code} - -