X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FSubst.lhs;h=dee369ceef959bd08e37a69d1ba2883c33cf8a02;hb=d32c5227315009f38355fe3233f0f4e5b1f61dc6;hp=aa60c04ba7132d3c6d0d23e73b71b4d7cbcb27cf;hpb=e80b5e1afc83493593446e1cc4fa76f45e6a4512;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index aa60c04..dee369c 100644 --- a/ghc/compiler/coreSyn/Subst.lhs +++ b/ghc/compiler/coreSyn/Subst.lhs @@ -28,10 +28,10 @@ module Subst ( -- Type stuff mkTyVarSubst, mkTopTyVarSubst, - substTyWith, substTy, substTheta, + substTyWith, substTy, substTheta, deShadowTy, -- Expression stuff - substExpr + substExpr, substRules ) where #include "HsVersions.h" @@ -43,9 +43,10 @@ import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, Unfolding(..) ) import CoreFVs ( exprFreeVars ) +import CoreUtils ( exprIsTrivial ) import TypeRep ( Type(..), TyNote(..) ) -- friend -import Type ( ThetaType, SourceType(..), PredType, - tyVarsOfType, tyVarsOfTypes, mkAppTy, mkUTy, isUTy +import Type ( ThetaType, PredType(..), + tyVarsOfType, tyVarsOfTypes, mkAppTy, ) import VarSet import VarEnv @@ -56,9 +57,9 @@ import Id ( idType, idInfo, setIdInfo, setIdType, 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 ) @@ -130,7 +131,7 @@ lookupInScope (InScope in_scope n) v 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 @@ -248,13 +249,12 @@ substInScope (Subst in_scope _) = in_scope 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 = 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 @@ -375,14 +375,23 @@ type TyVarSubst = Subst -- TyVarSubst are expected to have range elements -- 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 + +-- 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 @@ -409,17 +418,17 @@ substTy :: Subst -> Type -> Type 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 | 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 @@ -427,7 +436,10 @@ subst_ty subst 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 @@ -440,8 +452,6 @@ subst_ty subst ty 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. @@ -525,7 +535,7 @@ substExpr subst expr 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 @@ -562,7 +572,7 @@ simplBndr :: Subst -> Var -> (Subst, Var) -- 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 @@ -581,7 +591,7 @@ simplLamBndr subst bndr = (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) @@ -610,43 +620,41 @@ simplLetId subst@(Subst in_scope env) old_id | 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 - = case substIdInfo subst isFragileOcc old_info of - Just new_info -> bndr `setIdInfo` new_info - Nothing -> bndr `setIdInfo` old_info +simplIdInfo subst old_info + = 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 @@ -662,7 +670,7 @@ subst_id :: (OccInfo -> Bool) -- True <=> the OccInfo is fragile -- 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 @@ -674,7 +682,7 @@ subst_id is_fragile_occ rec_subst subst@(Subst in_scope env) old_id -- 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 @@ -698,7 +706,7 @@ subst_clone_id rec_subst subst@(Subst in_scope env) (old_id, uniq) 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]) @@ -725,41 +733,49 @@ substAndCloneId subst@(Subst in_scope env) us old_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 @@ -783,8 +799,10 @@ 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 ) + (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 @@ -807,9 +825,9 @@ substRules subst (Rules rules rhs_fvs) 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 @@ -824,10 +842,4 @@ substVarSet subst fvs 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}