From 2a3c28723075eb36e3faa2bfb6c46d934e05f208 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Fri, 4 Aug 2006 19:35:30 +0000 Subject: [PATCH] Massive patch for the first months work adding System FC to GHC #6 Broken up massive patch -=chak Original log message: This is (sadly) all done in one patch to avoid Darcs bugs. It's not complete work... more FC stuff to come. A compiler using just this patch will fail dismally. --- compiler/coreSyn/CoreSubst.lhs | 44 +++++++++++++++++++++++++++------------ compiler/coreSyn/CoreUnfold.lhs | 2 ++ 2 files changed, 33 insertions(+), 13 deletions(-) diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index addda3a..ac56176 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -35,7 +35,7 @@ import Type ( Type, tyVarsOfType, TvSubstEnv, TvSubst(..), mkTyVarTy ) import VarSet import VarEnv import Var ( setVarUnique, isId ) -import Id ( idType, setIdType, maybeModifyIdInfo, isLocalId ) +import Id ( idType, idInfo, setIdType, maybeModifyIdInfo, isLocalId ) import IdInfo ( IdInfo, SpecInfo(..), specInfo, setSpecInfo, isEmptySpecInfo, unfoldingInfo, setUnfoldingInfo, seqSpecInfo, WorkerInfo(..), workerExists, workerInfo, setWorkerInfo @@ -43,7 +43,7 @@ import IdInfo ( IdInfo, SpecInfo(..), specInfo, setSpecInfo, isEmptySpecInfo, import Unique ( Unique ) import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply ) import Var ( Var, Id, TyVar, isTyVar ) -import Maybes ( orElse ) +import Maybes ( orElse, isNothing ) import Outputable import PprCore () -- Instances import Util ( mapAccumL ) @@ -124,17 +124,28 @@ extendTvSubstList (Subst in_scope ids tvs) prs = Subst in_scope ids (extendVarEn lookupIdSubst :: Subst -> Id -> CoreExpr lookupIdSubst (Subst in_scope ids tvs) v | not (isLocalId v) = Var v - | otherwise - = case lookupVarEnv ids v of { - Just e -> e ; - Nothing -> + | otherwise = case lookupVarEnv ids v of + Just e -> e + Nothing -> Var v + +{- We used to have to look up in the in-scope set, + because GADTs were implicit in the intermediate language + But with FC, the type of an Id does not change in its scope + The worst that can happen if we don't look up in the in-scope set + is that we don't propagate IdInfo as vigorously as we might. + But that'll happen (when it's useful) in SimplEnv.substId + + If you put this back in, you should worry about the + Just e -> e + case above too! + case lookupInScope in_scope v of { -- Watch out! Must get the Id from the in-scope set, -- because its type there may differ Just v -> Var v ; Nothing -> WARN( True, ptext SLIT("CoreSubst.lookupIdSubst") <+> ppr v ) Var v - }} +-} lookupTvSubst :: Subst -> TyVar -> Type lookupTvSubst (Subst _ ids tvs) v = lookupVarEnv tvs v `orElse` mkTyVarTy v @@ -182,6 +193,7 @@ substExpr subst expr go (Lit lit) = Lit lit go (App fun arg) = App (go fun) (go arg) go (Note note e) = Note (go_note note) (go e) + go (Cast e co) = Cast (go e) (substTy subst co) go (Lam bndr body) = Lam bndr' (substExpr subst' body) where (subst', bndr') = substBndr subst bndr @@ -198,7 +210,6 @@ substExpr subst expr where (subst', bndrs') = substBndrs subst bndrs - go_note (Coerce ty1 ty2) = Coerce (substTy subst ty1) (substTy subst ty2) go_note note = note substBind :: Subst -> CoreBind -> (Subst, CoreBind) @@ -264,17 +275,24 @@ substIdBndr rec_subst subst@(Subst in_scope env tvs) old_id = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id) where id1 = uniqAway in_scope old_id -- id1 is cloned if necessary - id2 = substIdType subst id1 -- id2 has its type zapped + id2 | no_type_change = id1 + | otherwise = setIdType id1 (substTy subst old_ty) + + old_ty = idType old_id + no_type_change = isEmptyVarEnv tvs || isEmptyVarSet (tyVarsOfType old_ty) -- 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) id2 + new_id = maybeModifyIdInfo mb_new_info id2 + mb_new_info = substIdInfo rec_subst (idInfo id2) -- Extend the substitution if the unique has changed -- See the notes with substTyVarBndr for the delVarEnv - new_env | new_id /= old_id = extendVarEnv env old_id (Var new_id) - | otherwise = delVarEnv env old_id + new_env | no_change = delVarEnv env old_id + | otherwise = extendVarEnv env old_id (Var new_id) + + no_change = False -- id1 == old_id && isNothing mb_new_info && no_type_change \end{code} Now a variant that unconditionally allocates a new unique. @@ -307,7 +325,7 @@ clone_id rec_subst subst@(Subst in_scope env tvs) (old_id, uniq) where id1 = setVarUnique old_id uniq id2 = substIdType subst id1 - new_id = maybeModifyIdInfo (substIdInfo rec_subst) id2 + new_id = maybeModifyIdInfo (substIdInfo rec_subst (idInfo old_id)) id2 new_env = extendVarEnv env old_id (Var new_id) \end{code} diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 169c4ec..6849510 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -200,6 +200,8 @@ sizeExpr bOMB_OUT_SIZE top_args expr -- then we'll get a dfun which is a pair of two INLINE lambdas size_up (Note _ body) = size_up body -- Other notes cost nothing + + size_up (Cast e _) = size_up e size_up (App fun (Type t)) = size_up fun size_up (App fun arg) = size_up_app fun [arg] -- 1.7.10.4