X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FSubst.lhs;h=212e914f9cecf264529bc9582cc2d6d5213a465e;hb=de0864de66d27f8d7523fac11ecfae0347b739f3;hp=ec86225e188be3da15afdfb44067547608caf2de;hpb=b4775e5e760111e2d71fba3c44882dce390edfb2;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index ec86225..212e914 100644 --- a/ghc/compiler/coreSyn/Subst.lhs +++ b/ghc/compiler/coreSyn/Subst.lhs @@ -23,15 +23,15 @@ module Subst ( bindSubst, unBindSubst, bindSubstList, unBindSubstList, -- Binders - simplBndr, simplBndrs, simplLetId, simplIdInfo, + simplBndr, simplBndrs, simplLetId, simplLamBndr, simplIdInfo, substAndCloneId, substAndCloneIds, substAndCloneRecIds, -- Type stuff mkTyVarSubst, mkTopTyVarSubst, - substTy, substTheta, + substTyWith, substTy, substTheta, deShadowTy, -- Expression stuff - substExpr, substIdInfo + substExpr, substRules ) where #include "HsVersions.h" @@ -39,17 +39,19 @@ module Subst ( 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(..), - tyVarsOfType, tyVarsOfTypes, mkAppTy, mkUTy, isUTy +import Type ( ThetaType, SourceType(..), PredType, + 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, @@ -247,12 +249,10 @@ zapSubstEnv :: Subst -> Subst 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 @@ -372,34 +372,63 @@ type TyVarSubst = Subst -- TyVarSubst are expected to have range elements -- 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)) + (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 = 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 +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 subst (ClassP clas tys) = ClassP 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 @@ -407,7 +436,7 @@ subst_ty subst 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 @@ -420,8 +449,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. @@ -537,10 +564,9 @@ substExpr subst expr 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 @@ -548,13 +574,32 @@ simplBndr 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 @@ -572,18 +617,18 @@ 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 +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} -- 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 @@ -706,7 +751,6 @@ substIdInfo subst is_fragile_occ info | 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 @@ -714,15 +758,14 @@ substIdInfo subst is_fragile_occ info 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 @@ -733,6 +776,7 @@ substIdType subst@(Subst in_scope env) 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 @@ -748,6 +792,13 @@ substWorker subst (HasWorker w a) (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 @@ -760,14 +811,15 @@ 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 (subst', tpl_vars') = substBndrs subst tpl_vars +------------------ substVarSet subst fvs = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs where @@ -776,9 +828,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}