bindSubst, unBindSubst, bindSubstList, unBindSubstList,
-- Binders
- simplBndr, simplBndrs, simplLetId, simplIdInfo,
+ simplBndr, simplBndrs, simplLetId, simplLamBndr, simplIdInfo,
substAndCloneId, substAndCloneIds, substAndCloneRecIds,
-- Type stuff
mkTyVarSubst, mkTopTyVarSubst,
- substTyWith, substTy, substTheta,
+ substTyWith, substTy, substTheta, deShadowTy,
-- Expression stuff
- substExpr, substIdInfo
+ substExpr, substRules
) 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, SourceType(..), PredType,
- tyVarsOfType, tyVarsOfTypes, mkAppTy, mkUTy, isUTy,
- getTyVar_maybe
+ tyVarsOfType, tyVarsOfTypes, mkAppTy,
)
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,
zapSubstEnv (Subst in_scope env) = Subst in_scope emptySubstEnv
extendSubst :: Subst -> Var -> SubstResult -> Subst
-extendSubst (Subst in_scope env) v r = UASSERT( case r of { DoneTy ty -> not (isUTy ty) ; _ -> True } )
- Subst in_scope (extendSubstEnv env v r)
+extendSubst (Subst in_scope env) v r = Subst in_scope (extendSubstEnv env v r)
extendSubstList :: Subst -> [Var] -> [SubstResult] -> Subst
-extendSubstList (Subst in_scope env) v r = UASSERT( all (\ r1 -> case r1 of { DoneTy ty -> not (isUTy ty) ; _ -> True }) r )
- Subst in_scope (extendSubstEnvList env v r)
+extendSubstList (Subst in_scope env) v r = Subst in_scope (extendSubstEnvList env v r)
lookupSubst :: Subst -> Var -> Maybe SubstResult
lookupSubst (Subst _ env) v = lookupSubstEnv env v
-- it'll never be evaluated
mkTyVarSubst :: [TyVar] -> [Type] -> Subst
mkTyVarSubst tyvars tys = Subst (mkInScopeSet (tyVarsOfTypes tys))
- (zip_ty_env tyvars tys emptySubstEnv)
+ (zipTyEnv tyvars tys)
-- mkTopTyVarSubst is called when doing top-level substitutions.
-- Here we expect that the free vars of the range of the
-- substitution will be empty.
mkTopTyVarSubst :: [TyVar] -> [Type] -> Subst
-mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zip_ty_env tyvars tys emptySubstEnv)
+mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zipTyEnv tyvars tys)
+
+zipTyEnv tyvars tys
+#ifdef DEBUG
+ | length tyvars /= length tys
+ = pprTrace "mkTopTyVarSubst" (ppr tyvars $$ ppr tys) emptySubstEnv
+ | otherwise
+#endif
+ = zip_ty_env tyvars tys emptySubstEnv
zip_ty_env [] [] env = env
-zip_ty_env (tv:tvs) (ty:tys) env
- | Just tv' <- getTyVar_maybe ty, tv==tv' = zip_ty_env tvs tys env
- -- Shortcut for the (I think not uncommon) case where we are
- -- making an identity substitution
- | otherwise = 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.
substTy subst ty | isEmptySubst subst = ty
| otherwise = subst_ty subst ty
+deShadowTy :: Type -> Type -- Remove any shadowing from the type
+deShadowTy ty = subst_ty emptySubst ty
+
substTheta :: TyVarSubst -> ThetaType -> ThetaType
substTheta subst theta
| isEmptySubst subst = theta
go (ForAllTy tv ty) = case substTyVar subst tv of
(subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
-
- go (UsageTy u ty) = mkUTy (go u) $! (go ty)
\end{code}
Here is where we invent a new binder if necessary.
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
| otherwise
= delSubstEnv env old_id
-simplIdInfo :: Subst -> IdInfo -> Id -> Id
+simplIdInfo :: Subst -> IdInfo -> IdInfo
-- Used by the simplifier to compute new IdInfo for a let(rec) binder,
-- subsequent to simplLetId having zapped its IdInfo
-simplIdInfo subst old_info bndr
+simplIdInfo subst old_info
= case substIdInfo subst isFragileOcc old_info of
- Just new_info -> bndr `setIdInfo` new_info
- Nothing -> bndr `setIdInfo` old_info
+ Just new_info -> new_info
+ Nothing -> old_info
\end{code}
\begin{code}
| otherwise = Just (info `setOccInfo` (if zap_occ then NoOccInfo else old_occ)
`setSpecInfo` substRules subst old_rules
`setWorkerInfo` substWorker subst old_wrkr
- `setLBVarInfo` substLBVar subst old_lbv
`setUnfoldingInfo` noUnfolding)
-- setSpecInfo does a seq
-- setWorkerInfo does a seq
nothing_to_do = not zap_occ &&
isEmptyCoreRules old_rules &&
not (workerExists old_wrkr) &&
- hasNoLBVarInfo old_lbv &&
not (hasUnfolding (unfoldingInfo info))
zap_occ = is_fragile_occ old_occ
old_occ = occInfo info
old_rules = specInfo info
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
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'
+ do_subst rule@(BuiltinRule _ _) = rule
+ do_subst (Rule name act tpl_vars lhs_args rhs)
+ = Rule name act tpl_vars'
(map (substExpr subst') lhs_args)
(substExpr subst' rhs)
where
(subst', tpl_vars') = substBndrs subst tpl_vars
+------------------
substVarSet subst fvs
= foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
where
DoneEx expr -> exprFreeVars expr
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
- ty1 = substTy subst ty
\end{code}