X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FsimplCore%2FSimplEnv.lhs;h=fca0d611ec3f482637d490d4b259688427984f78;hb=6b4592943b799175dec4549882bbf06fa87a0739;hp=c7b48265585bb906438f64b2a18dec628a6ed9c8;hpb=182ce7e265699c9fd326f59d29767923100a2d16;p=ghc-hetmet.git diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index c7b4826..fca0d61 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -7,6 +7,7 @@ module SimplEnv ( InId, InBind, InExpr, InAlt, InArg, InType, InBinder, OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder, + InCoercion, OutCoercion, -- The simplifier mode setMode, getMode, @@ -21,7 +22,7 @@ module SimplEnv ( SimplEnv, mkSimplEnv, extendIdSubst, extendTvSubst, zapSubstEnv, setSubstEnv, getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds, - getRules, refineSimplEnv, + getRules, SimplSR(..), mkContEx, substId, @@ -41,12 +42,11 @@ module SimplEnv ( import SimplMonad import Id ( Id, idType, idOccInfo, idUnfolding, setIdUnfolding ) import IdInfo ( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecInfo, - arityInfo, setArityInfo, workerInfo, setWorkerInfo, + arityInfo, workerInfo, setWorkerInfo, unfoldingInfo, setUnfoldingInfo, isEmptySpecInfo, - unknownArity, workerExists + workerExists ) import CoreSyn -import Unify ( TypeRefinement ) import Rules ( RuleBase ) import CoreUtils ( needsCaseBinding ) import CostCentre ( CostCentreStack, subsumedCCS ) @@ -58,8 +58,9 @@ import OrdList import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substWorker ) import qualified Type ( substTy, substTyVarBndr ) -import Type ( Type, TvSubst(..), TvSubstEnv, composeTvSubst, +import Type ( Type, TvSubst(..), TvSubstEnv, isUnLiftedType, seqType, tyVarsOfType ) +import Coercion ( Coercion ) import BasicTypes ( OccInfo(..), isFragileOcc ) import DynFlags ( SimplifierMode(..) ) import Util ( mapAccumL ) @@ -73,22 +74,24 @@ import Outputable %************************************************************************ \begin{code} -type InBinder = CoreBndr -type InId = Id -- Not yet cloned -type InType = Type -- Ditto -type InBind = CoreBind -type InExpr = CoreExpr -type InAlt = CoreAlt -type InArg = CoreArg - -type OutBinder = CoreBndr -type OutId = Id -- Cloned -type OutTyVar = TyVar -- Cloned -type OutType = Type -- Cloned -type OutBind = CoreBind -type OutExpr = CoreExpr -type OutAlt = CoreAlt -type OutArg = CoreArg +type InBinder = CoreBndr +type InId = Id -- Not yet cloned +type InType = Type -- Ditto +type InBind = CoreBind +type InExpr = CoreExpr +type InAlt = CoreAlt +type InArg = CoreArg +type InCoercion = Coercion + +type OutBinder = CoreBndr +type OutId = Id -- Cloned +type OutTyVar = TyVar -- Cloned +type OutType = Type -- Cloned +type OutCoercion = Coercion +type OutBind = CoreBind +type OutExpr = CoreExpr +type OutAlt = CoreAlt +type OutArg = CoreArg \end{code} %************************************************************************ @@ -121,7 +124,7 @@ type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr 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 @@ -148,11 +151,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 @@ -165,12 +163,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: @@ -197,38 +192,6 @@ seIdSubst: That's why the "set" is actually a VarEnv Var -Note [GADT type refinement] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we come to a GADT pattern match that refines the in-scope types, we - a) Refine the types of the Ids in the in-scope set, seInScope. - For exmaple, consider - data T a where - Foo :: T (Bool -> Bool) - - (\ (x::T a) (y::a) -> case x of { Foo -> y True } - - Technically this is well-typed, but exprType will barf on the - (y True) unless we refine the type on y's occurrence. - - b) Refine the range of the type substitution, seTvSubst. - Very similar reason to (a). - - NB: we don't refine the range of the SimplIdSubst, because it's always - interpreted relative to the seInScope (see substId) - -For (b) we need to be a little careful. Specifically, we compose the refinement -with the type substitution. Suppose - The substitution was [a->b, b->a] - and the refinement was [b->Int] - Then we want [a->Int, b->a] - -But also if - The substitution was [a->b] - and the refinement was [b->Int] - Then we want [a->Int, b->Int] - becuase b might be both an InTyVar and OutTyVar - - \begin{code} mkSimplEnv :: SimplifierMode -> SwitchChecker -> RuleBase -> SimplEnv mkSimplEnv mode switches rules @@ -309,31 +272,6 @@ getRules :: SimplEnv -> RuleBase getRules = seExtRules \end{code} - GADT stuff - -Given an idempotent substitution, generated by the unifier, use it to -refine the environment - -\begin{code} -refineSimplEnv :: SimplEnv -> TypeRefinement -> SimplEnv --- The TvSubstEnv is the refinement, and it refines OutTyVars into OutTypes -refineSimplEnv env@(SimplEnv { seTvSubst = tv_subst, seInScope = in_scope }) - (refine_tv_subst, all_bound_here) - = env { seTvSubst = composeTvSubst in_scope refine_tv_subst tv_subst, - seInScope = in_scope' } - where - in_scope' - | all_bound_here = in_scope - -- The tvs are the tyvars bound here. If only they - -- are refined, there's no need to do anything - | otherwise = mapInScopeSet refine_id in_scope - - refine_id v -- Only refine its type; any rules will get - -- refined if they are used (I hope) - | isId v = setIdType v (Type.substTy refine_subst (idType v)) - | otherwise = v - refine_subst = TvSubst in_scope refine_tv_subst -\end{code} %************************************************************************ %* * @@ -346,24 +284,16 @@ refineSimplEnv env@(SimplEnv { seTvSubst = tv_subst, seInScope = in_scope }) substId :: SimplEnv -> Id -> SimplSR substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v | not (isLocalId v) - = DoneId v NoOccInfo + = DoneId v | 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 + Just (DoneId v) -> DoneId (refine v) + Just res -> res + Nothing -> DoneId (refine v) 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 with a different type (we only use the - -- substitution if the unique changes). + -- the in-scope set with better IdInfo refine v = case lookupInScope in_scope v of Just v' -> v' Nothing -> WARN( True, ppr v ) v -- This is an error! @@ -442,12 +372,12 @@ substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst}) -- new_id has the final IdInfo subst = mkCoreSubst env - new_id = maybeModifyIdInfo (substIdInfo subst) id2 + new_id = maybeModifyIdInfo (substIdInfo subst (idInfo old_id)) id2 -- Extend the substitution if the unique has changed -- 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} @@ -513,8 +443,8 @@ substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old -- 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) + new_subst | new_id /= old_id + = extendVarEnv id_subst old_id (DoneId new_id) | otherwise = delVarEnv id_subst old_id \end{code} @@ -611,8 +541,7 @@ substIdInfo subst info not (workerExists old_wrkr) && not (hasUnfolding (unfoldingInfo info)) - keep_occ = not (isFragileOcc old_occ) - old_arity = arityInfo info + keep_occ = not (isFragileOcc old_occ) old_occ = occInfo info old_rules = specInfo info old_wrkr = workerInfo info @@ -665,7 +594,7 @@ 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