-- Type stuff
mkTyVarSubst, mkTopTyVarSubst,
- substTy, substTheta,
+ substTy, substClasses, substTheta,
-- Expression stuff
substExpr, substIdInfo
CoreRules(..), CoreRule(..),
emptyCoreRules, isEmptyCoreRules, seqRules
)
-import CoreFVs ( exprFreeVars )
+import CoreFVs ( exprFreeVars, mustHaveLocalBinding )
import TypeRep ( Type(..), TyNote(..),
) -- friend
-import Type ( ThetaType,
+import Type ( ThetaType, PredType(..), ClassContext,
tyVarsOfType, tyVarsOfTypes, mkAppTy
)
import VarSet
import VarEnv
import Var ( setVarUnique, isId )
-import Id ( idType, setIdType, getIdOccInfo, zapFragileIdInfo )
-import Name ( isLocallyDefined )
+import Id ( idType, setIdType, idOccInfo, zapFragileIdInfo )
import IdInfo ( IdInfo, isFragileOccInfo,
specInfo, setSpecInfo,
- workerExists, workerInfo, setWorkerInfo, WorkerInfo
+ WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo
)
+import BasicTypes ( OccInfo(..) )
import UniqSupply ( UniqSupply, uniqFromSupply, splitUniqSupply )
-import Var ( Var, IdOrTyVar, Id, TyVar, isTyVar )
+import Var ( Var, Id, TyVar, isTyVar )
import Outputable
+import PprCore () -- Instances
import Util ( mapAccumL, foldl2, seqList, ($!) )
\end{code}
* substId adds a binding (DoneVar 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.
+
Note, though that the substitution isn't necessarily extended
if the type changes. Why not? Because of the next point:
-- Does the lookup in the in-scope set too
lookupIdSubst (Subst in_scope env) v
= case lookupSubstEnv env v of
- Just (DoneId v' occ) -> case lookupVarEnv in_scope v' of
- Just v'' -> DoneId v'' occ
- Nothing -> DoneId v' occ
+ Just (DoneId v' occ) -> DoneId (lookupInScope in_scope v') occ
Just res -> res
- Nothing -> DoneId v' (getIdOccInfo v')
+ Nothing -> DoneId v' (idOccInfo v')
+ -- We don't use DoneId for LoopBreakers, so the idOccInfo is
+ -- very important! If isFragileOccInfo returned True for
+ -- loop breakers we could avoid this call, but at the expense
+ -- of adding more to the substitution, and building new Ids
+ -- in substId a bit more often than really necessary
where
- v' = case lookupVarEnv in_scope v of
- Just v' -> v'
- Nothing -> v
-
-lookupInScope :: Subst -> Var -> Maybe Var
-lookupInScope (Subst in_scope _) v = lookupVarEnv in_scope v
+ v' = lookupInScope in_scope v
+
+lookupInScope :: InScopeSet -> Var -> Var
+-- It's important to look for a fixed point
+-- When we see (case x of y { I# v -> ... })
+-- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder).
+-- When we lookup up an occurrence of x, we map to y, but then
+-- we want to look up y in case it has acquired more evaluation information by now.
+lookupInScope in_scope v
+ = case lookupVarEnv in_scope v of
+ Just v' | v == v' -> v' -- Reached a fixed point
+ | otherwise -> lookupInScope in_scope v'
+ Nothing -> WARN( mustHaveLocalBinding v, ppr v )
+ v
isInScope :: Var -> Subst -> Bool
isInScope v (Subst in_scope _) = v `elemVarEnv` in_scope
substTy subst ty | isEmptySubst subst = ty
| otherwise = subst_ty subst ty
+substClasses :: TyVarSubst -> ClassContext -> ClassContext
+substClasses subst theta
+ | isEmptySubst subst = theta
+ | otherwise = [(clas, map (subst_ty subst) tys) | (clas, tys) <- theta]
+
substTheta :: TyVarSubst -> ThetaType -> ThetaType
substTheta subst theta
| isEmptySubst subst = theta
- | otherwise = [(clas, map (subst_ty subst) tys) | (clas, tys) <- theta]
+ | otherwise = map (substPred subst) theta
+
+substPred :: TyVarSubst -> PredType -> PredType
+substPred subst (Class clas tys) = Class clas (map (subst_ty subst) tys)
+substPred subst (IParam n ty) = IParam n (subst_ty subst ty)
subst_ty subst ty
= go ty
where
- go (TyConApp tc tys) = let args = map go tys
- in args `seqList` TyConApp tc args
- go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
- go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
- go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
+ go (TyConApp tc tys) = let args = map go tys
+ in args `seqList` TyConApp tc args
+ go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
+ go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
go (NoteTy (UsgNote usg) ty2) = (NoteTy $! UsgNote usg) $! go ty2 -- Keep usage annot
go (NoteTy (UsgForAll uv) ty2) = (NoteTy $! UsgForAll uv) $! go ty2 -- Keep uvar bdr
- go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
- go ty@(TyVarTy tv) = case (lookupSubst subst tv) of
+ go (NoteTy (IPNote nm) ty2) = (NoteTy $! IPNote nm) $! go ty2 -- Keep ip note
+
+ go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
+ go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
+ go ty@(TyVarTy tv) = case (lookupSubst subst tv) of
Nothing -> ty
Just (DoneTy ty') -> ty'
- go (ForAllTy tv ty) = case substTyVar subst tv of
+ go (ForAllTy tv ty) = case substTyVar subst tv of
(subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
\end{code}
DoneEx e' -> e'
go (Type ty) = Type (go_ty ty)
- go (Con con args) = Con con (map go args)
+ go (Lit lit) = Lit lit
go (App fun arg) = App (go fun) (go arg)
go (Note note e) = Note (go_note note) (go e)
(c) give it a new unique to avoid name clashes
\begin{code}
-substBndr :: Subst -> IdOrTyVar -> (Subst, IdOrTyVar)
+substBndr :: Subst -> Var -> (Subst, Var)
substBndr subst bndr
| isTyVar bndr = substTyVar subst bndr
| otherwise = substId subst bndr
-substBndrs :: Subst -> [IdOrTyVar] -> (Subst, [IdOrTyVar])
+substBndrs :: Subst -> [Var] -> (Subst, [Var])
substBndrs subst bndrs = mapAccumL substBndr subst bndrs
= (Subst (in_scope `add_in_scope` new_id) new_env, new_id)
where
id_ty = idType old_id
- occ_info = getIdOccInfo old_id
+ occ_info = idOccInfo old_id
-- id1 has its type zapped
id1 | noTypeSubst env
-- Seq'ing on the returned WorkerInfo is enough to cause all the
-- substitutions to happen completely
-substWorker subst Nothing
- = Nothing
-substWorker subst (Just w)
- = case lookupSubst subst w of
- Nothing -> Just w
- Just (DoneId w1 _) -> Just w1
- Just (DoneEx (Var w1)) -> Just w1
- Just (DoneEx other) -> WARN( True, text "substWorker: DoneEx" <+> ppr w )
- Nothing -- Worker has got substituted away altogether
- Just (ContEx se1 e) -> WARN( True, text "substWorker: ContEx" <+> ppr w )
- Nothing -- Ditto
+substWorker subst NoWorker
+ = NoWorker
+substWorker subst (HasWorker w a)
+ = case lookupIdSubst subst w of
+ (DoneId w1 _) -> HasWorker w1 a
+ (DoneEx (Var w1)) -> HasWorker w1 a
+ (DoneEx other) -> WARN( True, text "substWorker: DoneEx" <+> ppr w )
+ NoWorker -- Worker has got substituted away altogether
+ (ContEx se1 e) -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e)
+ NoWorker -- Ditto
substRules :: Subst -> CoreRules -> CoreRules
-- Seq'ing on the returned CoreRules is enough to cause all the
substRules subst (Rules rules rhs_fvs)
= seqRules new_rules `seq` new_rules
where
- new_rules = Rules (map do_subst rules)
- (subst_fvs (substEnv subst) rhs_fvs)
+ new_rules = Rules (map do_subst rules) (substVarSet subst rhs_fvs)
+ do_subst rule@(BuiltinRule _) = rule
do_subst (Rule name tpl_vars lhs_args rhs)
= Rule name tpl_vars'
(map (substExpr subst') lhs_args)
where
(subst', tpl_vars') = substBndrs subst tpl_vars
- subst_fvs se fvs
- = foldVarSet (unionVarSet . subst_fv) emptyVarSet rhs_fvs
- where
- subst_fv fv = case lookupSubstEnv se fv of
- Nothing -> unitVarSet fv
- Just (DoneId fv' _) -> unitVarSet fv'
- Just (DoneEx expr) -> exprFreeVars expr
- Just (DoneTy ty) -> tyVarsOfType ty
- Just (ContEx se' expr) -> subst_fvs se' (exprFreeVars expr)
+substVarSet subst fvs
+ = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
+ where
+ subst_fv subst fv = case lookupIdSubst subst fv of
+ DoneId fv' _ -> unitVarSet fv'
+ DoneEx expr -> exprFreeVars expr
+ DoneTy ty -> tyVarsOfType ty
+ ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr)
\end{code}
projects / ghc-hetmet.git / blobdiff