X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FSubst.lhs;h=ca5db14b323ab7bf5b50dd7c856d45b59a62670a;hb=4be00ac12eb12a88abadce5d38a17d53fc9339a9;hp=59a9ab5a3f5f8e8cc1a28ea79ea722515fed5c97;hpb=5d095cc1308afc5e539174f33fd3ff2bd9788bbd;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index 59a9ab5..ca5db14 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, - substTyWith, substTy, substTheta, + substTyWith, substTy, substTheta, deShadowTy, -- Expression stuff - substExpr, substIdInfo + substExpr ) where #include "HsVersions.h" @@ -39,18 +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, 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, @@ -248,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 @@ -374,20 +373,36 @@ 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 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. @@ -400,6 +415,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 @@ -431,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. @@ -558,6 +574,23 @@ 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 @@ -584,13 +617,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 +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} @@ -718,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 @@ -726,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 @@ -745,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 @@ -760,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 @@ -772,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 @@ -788,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}