X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplEnv.lhs;h=677a1e9d02cc60edd7a2f8a5d18e824099bd8e7c;hp=d1fd65f2a2e94f153a2e00e2bc4a191d104c6f71;hb=927df6486bc0dcb598b82702ca40c8fad0d9b25f;hpb=cc51a698c0938edaa3ccc95db19150bbaec6f795 diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index d1fd65f..677a1e9 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -1,42 +1,33 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1998 +o% (c) The AQUA Project, Glasgow University, 1993-1998 % \section[SimplMonad]{The simplifier Monad} \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module SimplEnv ( - InId, InBind, InExpr, InAlt, InArg, InType, InBndr, - OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr, + InId, InBind, InExpr, InAlt, InArg, InType, InBndr, InVar, + OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr, OutVar, InCoercion, OutCoercion, -- The simplifier mode - setMode, getMode, - - -- Switch checker - SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch, - isAmongSimpl, intSwitchSet, switchIsOn, + setMode, getMode, updMode, - setEnclosingCC, getEnclosingCC, + setEnclosingCC, getEnclosingCC, -- Environments - SimplEnv(..), pprSimplEnv, -- Temp not abstract - mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, + SimplEnv(..), StaticEnv, pprSimplEnv, -- Temp not abstract + mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, SimplEnv.extendCvSubst, zapSubstEnv, setSubstEnv, getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds, - getRules, + getSimplRules, SimplSR(..), mkContEx, substId, lookupRecBndr, simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, - simplBinder, simplBinders, addLetIdInfo, - substExpr, substTy, + simplBinder, simplBinders, addBndrRules, + substExpr, substTy, substTyVar, getTvSubst, + getCvSubst, substCo, substCoVar, + mkCoreSubst, -- Floats Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats, @@ -46,10 +37,10 @@ module SimplEnv ( #include "HsVersions.h" -import SimplMonad +import SimplMonad +import CoreMonad ( SimplifierMode(..) ) import IdInfo import CoreSyn -import Rules import CoreUtils import CostCentre import Var @@ -57,14 +48,17 @@ import VarEnv import VarSet import OrdList import Id -import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substWorker ) -import qualified Type ( substTy, substTyVarBndr ) -import Type hiding ( substTy, substTyVarBndr ) -import Coercion +import MkCore +import TysWiredIn +import qualified CoreSubst +import qualified Type +import Type hiding ( substTy, substTyVarBndr, substTyVar ) +import qualified Coercion +import Coercion hiding ( substCo, substTy, substCoVar, substCoVarBndr, substTyVarBndr ) import BasicTypes -import DynFlags -import Util +import MonadUtils import Outputable +import FastString import Data.List \end{code} @@ -77,6 +71,7 @@ import Data.List \begin{code} type InBndr = CoreBndr +type InVar = Var -- Not yet cloned type InId = Id -- Not yet cloned type InType = Type -- Ditto type InBind = CoreBind @@ -86,6 +81,7 @@ type InArg = CoreArg type InCoercion = Coercion type OutBndr = CoreBndr +type OutVar = Var -- Cloned type OutId = Id -- Cloned type OutTyVar = TyVar -- Cloned type OutType = Type -- Cloned @@ -106,28 +102,43 @@ type OutArg = CoreArg \begin{code} data SimplEnv = SimplEnv { + ----------- Static part of the environment ----------- + -- Static in the sense of lexically scoped, + -- wrt the original expression + seMode :: SimplifierMode, - seChkr :: SwitchChecker, - seCC :: CostCentreStack, -- The enclosing CCS (when profiling) + seCC :: CostCentreStack, -- The enclosing CCS (when profiling) + + -- The current substitution + seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType + seCvSubst :: CvSubstEnv, -- InTyCoVar |--> OutCoercion + seIdSubst :: SimplIdSubst, -- InId |--> OutExpr + + ----------- Dynamic part of the environment ----------- + -- Dynamic in the sense of describing the setup where + -- the expression finally ends up -- 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, + seFloats :: Floats -- See Note [Simplifier floats] - - -- The current substitution - seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType - seIdSubst :: SimplIdSubst -- InId |--> OutExpr - } +type StaticEnv = SimplEnv -- Just the static part is relevant + pprSimplEnv :: SimplEnv -> SDoc -- Used for debugging; selective pprSimplEnv env - = vcat [ptext SLIT("TvSubst:") <+> ppr (seTvSubst env), - ptext SLIT("IdSubst:") <+> ppr (seIdSubst env) ] + = vcat [ptext (sLit "TvSubst:") <+> ppr (seTvSubst env), + ptext (sLit "IdSubst:") <+> ppr (seIdSubst env), + ptext (sLit "InScope:") <+> vcat (map ppr_one in_scope_vars) + ] + where + in_scope_vars = varEnvElts (getInScopeVars (seInScope env)) + ppr_one v | isId v = ppr v <+> ppr (idUnfolding v) + | otherwise = ppr v type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr -- See Note [Extending the Subst] in CoreSubst @@ -136,13 +147,14 @@ data SimplSR = DoneEx OutExpr -- Completed term | DoneId OutId -- Completed term variable | ContEx TvSubstEnv -- A suspended substitution + CvSubstEnv 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 (DoneEx e) = ptext (sLit "DoneEx") <+> ppr e + ppr (DoneId v) = ptext (sLit "DoneId") <+> ppr v + ppr (ContEx _tv _cv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-, ppr (filter_env tv), ppr (filter_env id) -}] -- where -- fvs = exprFreeVars e @@ -150,7 +162,8 @@ instance Outputable SimplSR where -- keep uniq _ = uniq `elemUFM_Directly` fvs \end{code} - +Note [SimplEnv invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~ seInScope: The in-scope part of Subst includes *all* in-scope TyVars and Ids The elements of the set may have better IdInfo than the @@ -186,9 +199,8 @@ seIdSubst: * 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: + if the type of the Id changes. Why not? Because of the next point: * We *always, always* finish by looking up in the in-scope set any variable that doesn't get a DoneEx or DoneVar hit in the substitution. @@ -213,25 +225,50 @@ seIdSubst: \begin{code} -mkSimplEnv :: SimplifierMode -> SwitchChecker -> SimplEnv -mkSimplEnv mode switches - = SimplEnv { seChkr = switches, seCC = subsumedCCS, - seMode = mode, seInScope = emptyInScopeSet, - seFloats = emptyFloats, - seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv } +mkSimplEnv :: SimplifierMode -> SimplEnv +mkSimplEnv mode + = SimplEnv { seCC = subsumedCCS + , seMode = mode + , seInScope = init_in_scope + , seFloats = emptyFloats + , seTvSubst = emptyVarEnv + , seCvSubst = emptyVarEnv + , seIdSubst = emptyVarEnv } -- The top level "enclosing CC" is "SUBSUMED". ---------------------- -getSwitchChecker :: SimplEnv -> SwitchChecker -getSwitchChecker env = seChkr env +init_in_scope :: InScopeSet +init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy)) + -- See Note [WildCard binders] +\end{code} ---------------------- +Note [WildCard binders] +~~~~~~~~~~~~~~~~~~~~~~~ +The program to be simplified may have wild binders + case e of wild { p -> ... } +We want to *rename* them away, so that there are no +occurrences of 'wild-id' (with wildCardKey). The easy +way to do that is to start of with a representative +Id in the in-scope set + +There can be be *occurrences* of wild-id. For example, +MkCore.mkCoreApp transforms + e (a /# b) --> case (a /# b) of wild { DEFAULT -> e wild } +This is ok provided 'wild' isn't free in 'e', and that's the delicate +thing. Generally, you want to run the simplifier to get rid of the +wild-ids before doing much else. + +It's a very dark corner of GHC. Maybe it should be cleaned up. + +\begin{code} getMode :: SimplEnv -> SimplifierMode getMode env = seMode env setMode :: SimplifierMode -> SimplEnv -> SimplEnv setMode mode env = env { seMode = mode } +updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv +updMode upd env = env { seMode = upd (seMode env) } + --------------------- getEnclosingCC :: SimplEnv -> CostCentreStack getEnclosingCC env = seCC env @@ -242,12 +279,17 @@ setEnclosingCC env cc = env {seCC = cc} --------------------- extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res - = env {seIdSubst = extendVarEnv subst var res} + = ASSERT2( isId var && not (isCoVar var), ppr var ) + env {seIdSubst = extendVarEnv subst var res} extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res = env {seTvSubst = extendVarEnv subst var res} +extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv +extendCvSubst env@(SimplEnv {seCvSubst = subst}) var res + = env {seCvSubst = extendVarEnv subst var res} + --------------------- getInScope :: SimplEnv -> InScopeSet getInScope env = seInScope env @@ -275,26 +317,25 @@ 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 -zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv} +zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv} -setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv -setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids } +setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv +setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids } mkContEx :: SimplEnv -> InExpr -> SimplSR -mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e - -isEmptySimplSubst :: SimplEnv -> Bool -isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) - = isEmptyVarEnv tvs && isEmptyVarEnv ids +mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e \end{code} @@ -343,14 +384,14 @@ 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") + 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 flt = FltOkSpec +andFF FltOkSpec _ = FltOkSpec andFF FltLifted flt = flt classifyFF :: CoreBind -> FloatFlag @@ -364,7 +405,7 @@ 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 + want_to_float = isTopLevel lvl || exprIsExpandable rhs can_float = case ff of FltLifted -> True FltOkSpec -> isNotTopLevel lvl && isNonRec rec @@ -386,18 +427,18 @@ addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv -- 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), + = id `seq` -- This seq forces the Id, and hence its IdInfo, + -- and hence any inner substitutions + env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs), seInScope = extendInScopeSet (seInScope env) id } -extendFloats :: SimplEnv -> [OutBind] -> SimplEnv +extendFloats :: SimplEnv -> OutBind -> SimplEnv -- Add these bindings to the floats, and extend the in-scope env too -extendFloats env binds - = env { seFloats = seFloats env `addFlts` new_floats, +extendFloats env bind + = env { seFloats = seFloats env `addFlts` unitFloat bind, seInScope = extendInScopeSetList (seInScope env) bndrs } where - bndrs = bindersOfBinds binds - new_floats = Floats (toOL binds) - (foldr (andFF . classifyFF) FltLifted binds) + bndrs = bindersOf bind addFloats :: SimplEnv -> SimplEnv -> SimplEnv -- Add the floats for env2 to env1; @@ -420,7 +461,7 @@ addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv -- 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; other -> False }, ppr (fromOL bs) ) + = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) ) env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))} wrapFloats :: SimplEnv -> OutExpr -> OutExpr @@ -453,34 +494,45 @@ floatBinds (Floats bs _) = fromOL bs %* * %************************************************************************ +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 - | otherwise -- A local Id - = case lookupVarEnv ids v of - Just (DoneId v) -> DoneId (refine in_scope v) - Just res -> res - Nothing -> DoneId (refine in_scope v) - where + = 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 -- 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 with better IdInfo -refine in_scope v = case lookupInScope in_scope v of +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 -> Id -> Id +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 res -> pprPanic "lookupRecBndr" (ppr v) - Nothing -> refine in_scope v + Just _ -> pprPanic "lookupRecBndr" (ppr v) + Nothing -> refine in_scope v \end{code} @@ -496,8 +548,8 @@ These functions are in the monad only so that they can be made strict via seq. \begin{code} simplBinders, simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) -simplBinders env bndrs = mapAccumLSmpl simplBinder env bndrs -simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr env bndrs +simplBinders env bndrs = mapAccumLM simplBinder env bndrs +simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs ------------- simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) @@ -515,54 +567,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 + +--------------- +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) } --------------- -substIdBndr :: SimplEnv -> Id -- Substitition and Id to transform - -> (SimplEnv, Id) -- Transformed pair +--------------- +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 -> (SimplEnv, OutBndr) +-- Might be a coercion variable +substIdBndr env bndr + | isCoVar bndr = substCoVarBndr env bndr + | otherwise = substNonCoVarIdBndr env bndr --- Returns with: --- * Unique changed if necessary +--------------- +substNonCoVarIdBndr + :: 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 +-- * 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 -- --- Exactly like CoreSubst.substIdBndr, except that the type of id_subst differs - -substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst}) - old_id - = (env { seInScope = in_scope `extendInScopeSet` new_id, +-- 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 +substNonCoVarIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) + old_id + = ASSERT2( not (isCoVar old_id), ppr 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 - -- Also see Note [Extending the Subst] in CoreSubst new_subst | new_id /= old_id = extendVarEnv id_subst old_id (DoneId new_id) | otherwise @@ -584,78 +659,12 @@ seqIds [] = () 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 -> InBndr -> SimplM (SimplEnv, OutBndr) -simplNonRecBndr env id - = do { let (env1, id1) = substLetIdBndr env id - ; seqId id1 `seq` return (env1, id1) } - ---------------- -simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv -simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids - = do { let (env1, ids1) = mapAccumL substLetIdBndr env ids - ; seqIds ids1 `seq` return env1 } - ---------------- -substLetIdBndr :: SimplEnv - -> InBndr -- Env and binder to transform - -> (SimplEnv, OutBndr) --- C.f. substIdBndr above --- Clone Id if necessary, substitute its type --- Return an Id with its --- UnfoldingInfo zapped --- Rules, etc, substitutd with rec_subst --- Robust info, retained especially arity and demand info, --- so that they are available to occurrences that occur in an --- earlier binding of a letrec --- Augment the subtitution if the unique changed - -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 = zapFragileIdInfo id2 - - -- 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) - | otherwise - = delVarEnv id_subst old_id -\end{code} - -Note [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. @@ -669,7 +678,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 @@ -679,77 +688,36 @@ 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. -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 -> InBndr -> OutBndr -> (SimplEnv, OutBndr) -addLetIdInfo env in_id out_id - = case substIdInfo subst (idInfo in_id) of - Nothing -> (env, out_id) - Just new_info -> (modifyInScope env out_id final_id, final_id) - where - final_id = out_id `setIdInfo` new_info - where - subst = mkCoreSubst env - -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 - where - nothing_to_do = keep_occ && - isEmptySpecInfo old_rules && - not (workerExists old_wrkr) && - not (hasUnfolding (unfoldingInfo info)) - - keep_occ = not (isFragileOcc old_occ) - old_occ = occInfo info - old_rules = specInfo info - old_wrkr = workerInfo info +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. ------------------- -substIdType :: SimplEnv -> Id -> Id -substIdType env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id - | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id - | 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 - where - old_ty = idType id +See Note [Loop breaking and RULES] in OccAnal. ------------------- -substUnfolding env NoUnfolding = NoUnfolding -substUnfolding env (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 + +\begin{code} +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 + subst = mkCoreSubst (text "local rules") env + old_rules = idSpecialisation in_id + new_rules = CoreSubst.substSpec subst out_id old_rules + final_id = out_id `setIdSpecialisation` new_rules \end{code} @@ -760,34 +728,76 @@ substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rh %************************************************************************ \begin{code} +getTvSubst :: SimplEnv -> TvSubst +getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) + = mkTvSubst in_scope tv_env + +getCvSubst :: SimplEnv -> CvSubst +getCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) + = CvSubst in_scope tv_env cv_env + substTy :: SimplEnv -> Type -> Type -substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty - = Type.substTy (TvSubst in_scope tv_env) ty +substTy env ty = Type.substTy (getTvSubst env) ty + +substTyVar :: SimplEnv -> TyVar -> Type +substTyVar env tv = Type.substTyVar (getTvSubst env) tv substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar) -substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv - = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of +substTyVarBndr env tv + = case Type.substTyVarBndr (getTvSubst env) tv of (TvSubst in_scope' tv_env', tv') - -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv') + -> (env { seInScope = in_scope', seTvSubst = tv_env' }, tv') + +substCoVar :: SimplEnv -> CoVar -> Coercion +substCoVar env tv = Coercion.substCoVar (getCvSubst env) tv + +substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar) +substCoVarBndr env cv + = case Coercion.substCoVarBndr (getCvSubst env) cv of + (CvSubst in_scope' tv_env' cv_env', cv') + -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv') + +substCo :: SimplEnv -> Coercion -> Coercion +substCo env co = Coercion.substCo (getCvSubst env) co -- When substituting in rules etc we can get CoreSubst to do the work -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match -- here. I think the this will not usually result in a lot of work; -- the substitutions are typically small, and laziness will avoid work in many cases. -mkCoreSubst :: SimplEnv -> CoreSubst.Subst -mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env }) - = mk_subst tv_env id_env +mkCoreSubst :: SDoc -> SimplEnv -> CoreSubst.Subst +mkCoreSubst doc (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env, seIdSubst = id_env }) + = mk_subst tv_env cv_env id_env where - mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env) + mk_subst tv_env cv_env id_env = CoreSubst.mkSubst in_scope tv_env cv_env (mapVarEnv fiddle id_env) + + fiddle (DoneEx e) = e + fiddle (DoneId v) = Var v + fiddle (ContEx tv cv id e) = CoreSubst.substExpr (text "mkCoreSubst" <+> doc) (mk_subst tv cv id) e + -- Don't shortcut here - fiddle (DoneEx e) = e - fiddle (DoneId v) = Var v - fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e +------------------ +substIdType :: SimplEnv -> Id -> Id +substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) id + | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id + | 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 + where + old_ty = idType id -substExpr :: SimplEnv -> CoreExpr -> CoreExpr -substExpr env expr - | isEmptySimplSubst env = expr - | otherwise = CoreSubst.substExpr (mkCoreSubst env) expr +------------------ +substExpr :: SDoc -> SimplEnv -> CoreExpr -> CoreExpr +substExpr doc env + = CoreSubst.substExpr (text "SimplEnv.substExpr1" <+> doc) + (mkCoreSubst (text "SimplEnv.substExpr2" <+> doc) env) + -- Do *not* short-cut in the case of an empty substitution + -- See Note [SimplEnv invariants] + +substUnfolding :: SimplEnv -> Unfolding -> Unfolding +substUnfolding env unf = CoreSubst.substUnfolding (mkCoreSubst (text "subst-unfolding") env) unf + -- Do *not* short-cut in the case of an empty substitution + -- See Note [SimplEnv invariants] \end{code}