substTyWith, substTy, substTheta, deShadowTy,
-- Expression stuff
- substExpr
+ substExpr, substRules
) where
#include "HsVersions.h"
Unfolding(..)
)
import CoreFVs ( exprFreeVars )
+import CoreUtils ( exprIsTrivial )
import TypeRep ( Type(..), TyNote(..) ) -- friend
-import Type ( ThetaType, SourceType(..), PredType,
+import Type ( ThetaType, PredType(..),
tyVarsOfType, tyVarsOfTypes, mkAppTy,
)
import VarSet
import IdInfo ( IdInfo, vanillaIdInfo,
occInfo, isFragileOcc, setOccInfo,
specInfo, setSpecInfo,
+ setArityInfo, unknownArity, arityInfo,
unfoldingInfo, setUnfoldingInfo,
- WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo,
- lbvarInfo, LBVarInfo(..), setLBVarInfo, hasNoLBVarInfo
+ WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo
)
import BasicTypes ( OccInfo(..) )
import Unique ( Unique, Uniquable(..), deriveUnique )
uniqAway :: InScopeSet -> Var -> Var
-- (uniqAway in_scope v) finds a unique that is not used in the
-- in-scope set, and gives that to v. It starts with v's current unique, of course,
--- in the hope that it won't have to change it, nad thereafter uses a combination
+-- in the hope that it won't have to change it, and thereafter uses a combination
-- of that and the hash-code found in the in-scope set
uniqAway (InScope set n) var
| not (var `elemVarSet` set) = var -- Nothing to do
zapSubstEnv :: Subst -> Subst
zapSubstEnv (Subst in_scope env) = Subst in_scope emptySubstEnv
+-- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set
extendSubst :: Subst -> Var -> SubstResult -> Subst
extendSubst (Subst in_scope env) v r = Subst in_scope (extendSubstEnv env v r)
| length tyvars /= length tys
= pprTrace "mkTopTyVarSubst" (ppr tyvars $$ ppr tys) emptySubstEnv
| otherwise
- = zip_ty_env tyvars tys emptySubstEnv
#endif
+ = zip_ty_env tyvars tys emptySubstEnv
+-- Later substitutions in the list over-ride earlier ones
zip_ty_env [] [] env = env
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
| otherwise = map (substPred subst) theta
substPred :: TyVarSubst -> PredType -> PredType
-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)
+substPred subst (IParam n ty) = IParam n (subst_ty subst ty)
+substPred subst (ClassP clas tys) = ClassP clas (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 (SourceTy p) = SourceTy $! (substSourceType subst p)
+ go (NewTcApp tc tys) = let args = map go tys
+ in args `seqList` NewTcApp tc args
+
+ go (PredTy p) = PredTy $! (substPred subst p)
go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
go (Let (Rec pairs) body) = Let (Rec pairs') (substExpr subst' body)
where
- (subst', bndrs') = substRecIds subst (map fst pairs)
+ (subst', bndrs') = substRecBndrs subst (map fst pairs)
pairs' = bndrs' `zip` rhss'
rhss' = map (substExpr subst' . snd) pairs
-- 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
+ | otherwise = subst_id False subst subst bndr
simplBndrs :: Subst -> [Var] -> (Subst, [Var])
simplBndrs subst bndrs = mapAccumL simplBndr subst bndrs
= (subst', bndr' `setIdUnfolding` substUnfolding subst old_unf)
where
old_unf = idUnfolding bndr
- (subst', bndr') = subst_id isFragileOcc subst subst bndr
+ (subst', bndr') = subst_id False subst subst bndr
simplLetId :: Subst -> Id -> (Subst, Id)
-- Used by the simplifier to compute new IdInfo for a let(rec) binder,
-- subsequent to simplLetId having zapped its IdInfo
simplIdInfo subst old_info
- = case substIdInfo subst isFragileOcc old_info of
+ = case substIdInfo False subst old_info of
Just new_info -> new_info
Nothing -> old_info
\end{code}
\begin{code}
-- substBndr and friends are used when doing expression substitution only
-- 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
+-- to do so else lose useful occ info in rules.
substBndr :: Subst -> Var -> (Subst, Var)
substBndr subst bndr
| isTyVar bndr = substTyVar subst bndr
- | otherwise = subst_id keepOccInfo subst subst bndr
+ | otherwise = subst_id True {- keep fragile info -} subst subst bndr
substBndrs :: Subst -> [Var] -> (Subst, [Var])
substBndrs subst bndrs = mapAccumL substBndr subst bndrs
-substRecIds :: Subst -> [Id] -> (Subst, [Id])
+substRecBndrs :: Subst -> [Id] -> (Subst, [Id])
-- Substitute a mutually recursive group
-substRecIds subst bndrs
+substRecBndrs subst bndrs
= (new_subst, new_bndrs)
where
-- Here's the reason we need to pass rec_subst to subst_id
- (new_subst, new_bndrs) = mapAccumL (subst_id keepOccInfo new_subst) subst bndrs
-
-keepOccInfo occ = False -- Never fragile
+ (new_subst, new_bndrs) = mapAccumL (subst_id True {- keep fragile info -} new_subst)
+ subst bndrs
\end{code}
\begin{code}
-subst_id :: (OccInfo -> Bool) -- True <=> the OccInfo is fragile
+subst_id :: Bool -- True <=> keep fragile info
-> Subst -- Substitution to use for the IdInfo
-> Subst -> Id -- Substitition and Id to transform
-> (Subst, Id) -- Transformed pair
-- In this case, the var in the DoneId is the same as the
-- var returned
-subst_id is_fragile_occ rec_subst subst@(Subst in_scope env) old_id
+subst_id keep_fragile rec_subst subst@(Subst in_scope env) old_id
= (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
where
-- id1 is cloned if necessary
-- new_id has the right IdInfo
-- The lazy-set is because we're in a loop here, with
-- rec_subst, when dealing with a mutually-recursive group
- new_id = maybeModifyIdInfo (substIdInfo rec_subst is_fragile_occ) id2
+ new_id = maybeModifyIdInfo (substIdInfo keep_fragile rec_subst) id2
-- Extend the substitution if the unique has changed
-- See the notes with substTyVar for the delSubstEnv
id1 = setVarUnique old_id uniq
id2 = substIdType subst id1
- new_id = maybeModifyIdInfo (substIdInfo rec_subst isFragileOcc) id2
+ new_id = maybeModifyIdInfo (substIdInfo False rec_subst) id2
new_env = extendSubstEnv env old_id (DoneId new_id NoOccInfo)
substAndCloneIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
%************************************************************************
\begin{code}
-substIdInfo :: Subst
- -> (OccInfo -> Bool) -- True <=> zap the occurrence info
+substIdInfo :: Bool -- True <=> keep even fragile info
+ -> Subst
-> IdInfo
-> Maybe IdInfo
+-- The keep_fragile flag is True when we are running a simple expression
+-- substitution that preserves all structure, so that arity and occurrence
+-- info are unaffected. The False state is used more often.
+--
-- Substitute the
-- rules
-- worker info
--- LBVar info
-- Zap the unfolding
--- Zap the occ info if instructed to do so
+-- If keep_fragile then
+-- keep OccInfo
+-- keep Arity
+-- else
+-- keep only 'robust' OccInfo
+-- zap Arity
--
-- Seq'ing on the returned IdInfo is enough to cause all the
-- substitutions to happen completely
-substIdInfo subst is_fragile_occ info
+substIdInfo keep_fragile subst info
| nothing_to_do = Nothing
- | otherwise = Just (info `setOccInfo` (if zap_occ then NoOccInfo else old_occ)
+ | otherwise = Just (info `setOccInfo` (if keep_occ then old_occ else NoOccInfo)
+ `setArityInfo` (if keep_arity then old_arity else unknownArity)
`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
where
- nothing_to_do = not zap_occ &&
+ nothing_to_do = keep_occ && keep_arity &&
isEmptyCoreRules old_rules &&
not (workerExists old_wrkr) &&
- hasNoLBVarInfo old_lbv &&
not (hasUnfolding (unfoldingInfo info))
- zap_occ = is_fragile_occ old_occ
+ keep_occ = keep_fragile || not (isFragileOcc old_occ)
+ keep_arity = keep_fragile || old_arity == unknownArity
+ old_arity = arityInfo info
old_occ = occInfo info
old_rules = specInfo info
old_wrkr = workerInfo info
- old_lbv = lbvarInfo info
------------------
substIdType :: Subst -> Id -> Id
= 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 )
+ (DoneEx other) -> WARN( not (exprIsTrivial other), text "substWorker: DoneEx" <+> ppr w )
NoWorker -- Worker has got substituted away altogether
+ -- This can happen if it's trivial,
+ -- via postInlineUnconditionally
(ContEx se1 e) -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e)
NoWorker -- Ditto
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}
projects / ghc-hetmet.git / blobdiff