bindSubst, unBindSubst, bindSubstList, unBindSubstList,
-- Binders
- simplBndr, simplBndrs, simplLetId, simplIdInfo,
+ simplBndr, simplBndrs, simplLetId, simplLamBndr, simplIdInfo,
substAndCloneId, substAndCloneIds, substAndCloneRecIds,
-- Type stuff
mkTyVarSubst, mkTopTyVarSubst,
- substTy, substClasses, substTheta,
+ substTyWith, substTy, substTheta,
-- Expression stuff
- substExpr, substIdInfo
+ substExpr
) where
#include "HsVersions.h"
import CmdLineOpts ( opt_PprStyle_Debug )
import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr,
CoreRules(..), CoreRule(..),
- isEmptyCoreRules, seqRules, hasUnfolding, noUnfolding
+ isEmptyCoreRules, seqRules, hasUnfolding, noUnfolding, hasSomeUnfolding,
+ Unfolding(..)
)
import CoreFVs ( exprFreeVars )
import TypeRep ( Type(..), TyNote(..) ) -- friend
-import Type ( ThetaType, PredType(..), ClassContext,
+import Type ( ThetaType, SourceType(..), PredType,
tyVarsOfType, tyVarsOfTypes, mkAppTy, mkUTy, isUTy
)
import VarSet
import VarEnv
import Var ( setVarUnique, isId, mustHaveLocalBinding )
import Id ( idType, idInfo, setIdInfo, setIdType,
+ idUnfolding, setIdUnfolding,
idOccInfo, maybeModifyIdInfo )
import IdInfo ( IdInfo, vanillaIdInfo,
occInfo, isFragileOcc, setOccInfo,
-- the types given; but it's just a thunk so with a bit of luck
-- it'll never be evaluated
mkTyVarSubst :: [TyVar] -> [Type] -> Subst
-mkTyVarSubst tyvars tys = Subst (mkInScopeSet (tyVarsOfTypes tys)) (zip_ty_env tyvars tys emptySubstEnv)
+mkTyVarSubst tyvars tys = Subst (mkInScopeSet (tyVarsOfTypes tys))
+ (zip_ty_env tyvars tys emptySubstEnv)
-- mkTopTyVarSubst is called when doing top-level substitutions.
-- Here we expect that the free vars of the range of the
mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zip_ty_env tyvars tys emptySubstEnv)
zip_ty_env [] [] env = env
-zip_ty_env (tv:tvs) (ty:tys) env = UASSERT( not (isUTy ty) )
- zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty))
+zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty))
+ -- There used to be a special case for when
+ -- ty == TyVarTy tv
+ -- (a not-uncommon case) in which case the substitution was dropped.
+ -- But the type-tidier changes the print-name of a type variable without
+ -- changing the unique, and that led to a bug. Why? Pre-tidying, we had
+ -- a type {Foo t}, where Foo is a one-method class. So Foo is really a newtype.
+ -- And it happened that t was the type variable of the class. Post-tiding,
+ -- it got turned into {Foo t2}. The ext-core printer expanded this using
+ -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique,
+ -- and so generated a rep type mentioning t not t2.
+ --
+ -- Simplest fix is to nuke the "optimisation"
\end{code}
substTy works with general Substs, so that it can be called from substExpr too.
\begin{code}
+substTyWith :: [TyVar] -> [Type] -> Type -> Type
+substTyWith tvs tys = substTy (mkTyVarSubst tvs tys)
+
substTy :: Subst -> Type -> Type
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 = 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)
+substPred = substSourceType
+
+substSourceType subst (IParam n ty) = IParam n (subst_ty subst ty)
+substSourceType subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys)
+substSourceType subst (NType tc tys) = NType tc (map (subst_ty subst) tys)
subst_ty subst ty
= go ty
go (TyConApp tc tys) = let args = map go tys
in args `seqList` TyConApp tc args
- go (PredTy p) = PredTy $! (substPred subst p)
+ go (SourceTy p) = SourceTy $! (substSourceType subst p)
go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
simplBndr :: Subst -> Var -> (Subst, Var)
-- Used for lambda and case-bound variables
-- Clone Id if necessary, substitute type
--- Return with IdInfo already substituted,
--- but occurrence info zapped
+-- Return with IdInfo already substituted, but (fragile) occurrence info zapped
-- The substitution is extended only if the variable is cloned, because
--- we don't need to use it to track occurrence info.
+-- we *don't* need to use it to track occurrence info.
simplBndr subst bndr
| isTyVar bndr = substTyVar subst bndr
| otherwise = subst_id isFragileOcc subst subst bndr
simplBndrs :: Subst -> [Var] -> (Subst, [Var])
simplBndrs subst bndrs = mapAccumL simplBndr subst bndrs
+simplLamBndr :: Subst -> Var -> (Subst, Var)
+-- Used for lambda binders. These sometimes have unfoldings added by
+-- the worker/wrapper pass that must be preserved, becuase 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 subst bndr
+ | not (isId bndr && hasSomeUnfolding old_unf)
+ = simplBndr subst bndr -- Normal case
+ | otherwise
+ = (subst', bndr' `setIdUnfolding` substUnfolding subst old_unf)
+ where
+ old_unf = idUnfolding bndr
+ (subst', bndr') = subst_id isFragileOcc subst subst bndr
+
+
simplLetId :: Subst -> Id -> (Subst, Id)
-- Clone Id if necessary
-- Substitute its type
-- Return an Id with completely zapped IdInfo
--- Augment the subtitution if the unique changed or if there's
--- interesting occurrence info
--- [A subsequent substIdInfo will restore its IdInfo]
+-- [A subsequent substIdInfo will restore its IdInfo]
+-- Augment the subtitution
+-- if the unique changed, *or*
+-- if there's interesting occurrence info
+
simplLetId subst@(Subst in_scope env) old_id
= (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
where
\begin{code}
-- substBndr and friends are used when doing expression substitution only
--- In this case we can preserve occurrence information, and indeed we want
+-- In this case we can *preserve* occurrence information, and indeed we *want*
-- to do so else lose useful occ info in rules. Hence the calls to
-- simpl_id with keepOccInfo
substAndCloneIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
substAndCloneIds subst us ids
- = mapAccumL (subst_clone_id subst) subst (ids `zip` uniqsFromSupply (length ids) us)
+ = mapAccumL (subst_clone_id subst) subst (ids `zip` uniqsFromSupply us)
substAndCloneRecIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
substAndCloneRecIds subst us ids
= (subst', ids')
where
(subst', ids') = mapAccumL (subst_clone_id subst') subst
- (ids `zip` uniqsFromSupply (length ids) us)
+ (ids `zip` uniqsFromSupply us)
substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, Id)
substAndCloneId subst@(Subst in_scope env) us old_id
old_wrkr = workerInfo info
old_lbv = lbvarInfo info
+------------------
substIdType :: Subst -> Id -> Id
substIdType subst@(Subst in_scope env) id
| noTypeSubst env || isEmptyVarSet (tyVarsOfType old_ty) = id
where
old_ty = idType id
+------------------
substWorker :: Subst -> WorkerInfo -> WorkerInfo
-- Seq'ing on the returned WorkerInfo is enough to cause all the
-- substitutions to happen completely
(ContEx se1 e) -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e)
NoWorker -- Ditto
+------------------
+substUnfolding subst NoUnfolding = NoUnfolding
+substUnfolding subst (OtherCon cons) = OtherCon cons
+substUnfolding subst (CompulsoryUnfolding rhs) = CompulsoryUnfolding (substExpr subst rhs)
+substUnfolding subst (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr subst rhs) t v w g
+
+------------------
substRules :: Subst -> CoreRules -> CoreRules
-- Seq'ing on the returned CoreRules is enough to cause all the
-- substitutions to happen completely
where
(subst', tpl_vars') = substBndrs subst tpl_vars
+------------------
substVarSet subst fvs
= foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
where
DoneTy ty -> tyVarsOfType ty
ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr)
+------------------
substLBVar subst NoLBVarInfo = NoLBVarInfo
substLBVar subst (LBVarInfo ty) = ty1 `seq` LBVarInfo ty1
where
projects / ghc-hetmet.git / blobdiff