X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FSubst.lhs;h=c406f926e01698619a8631b0fbfa4d265bd8b25e;hb=4be58768d4974fd1bddae44f12a0fde1f7fe6b30;hp=f22827480c66ddbb572995bd9184fce22879adb7;hpb=5ab261bb3fd75f45a4f219f1399be84208e12463;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index f228274..c406f92 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" @@ -45,7 +45,7 @@ import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, import CoreFVs ( exprFreeVars ) import TypeRep ( Type(..), TyNote(..) ) -- friend import Type ( ThetaType, SourceType(..), PredType, - tyVarsOfType, tyVarsOfTypes, mkAppTy, mkUTy, isUTy + tyVarsOfType, tyVarsOfTypes, mkAppTy, ) import VarSet import VarEnv @@ -56,6 +56,7 @@ 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 @@ -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,6 +418,9 @@ 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 @@ -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,13 +620,13 @@ 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} @@ -628,25 +638,26 @@ simplIdInfo subst old_info bndr 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 + (new_subst, new_bndrs) = mapAccumL (subst_id True {- keep fragile info -} new_subst) + subst bndrs keepOccInfo occ = False -- Never fragile \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 +673,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 +685,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 +709,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 +736,50 @@ 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 @@ -808,8 +828,8 @@ substRules subst (Rules rules 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' + 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 +844,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}