X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FVarEnv.lhs;h=fca625692f47ef9365d5503524b6d4f70fc537a1;hb=e5d8b4d0c6dd20a51597517208cbd4b0cc50c7de;hp=4bb00cf2c9071e9a5a411896320fa50665d1d82b;hpb=0c090fc451916dc3f2edb4b2f0053a6fdcea5554;p=ghc-hetmet.git diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs index 4bb00cf..fca6256 100644 --- a/compiler/basicTypes/VarEnv.lhs +++ b/compiler/basicTypes/VarEnv.lhs @@ -6,20 +6,21 @@ \begin{code} module VarEnv ( -- * Var, Id and TyVar environments (maps) - VarEnv, IdEnv, TyVarEnv, + VarEnv, IdEnv, TyVarEnv, CoVarEnv, -- ** Manipulating these environments emptyVarEnv, unitVarEnv, mkVarEnv, elemVarEnv, varEnvElts, varEnvKeys, - extendVarEnv, extendVarEnv_C, extendVarEnvList, + extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnvList, plusVarEnv, plusVarEnv_C, delVarEnvList, delVarEnv, + minusVarEnv, intersectsVarEnv, lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, mapVarEnv, zipVarEnv, modifyVarEnv, modifyVarEnv_Directly, isEmptyVarEnv, foldVarEnv, elemVarEnvByKey, lookupVarEnv_Directly, - filterVarEnv_Directly, + filterVarEnv_Directly, restrictVarEnv, -- * The InScopeSet type InScopeSet, @@ -27,15 +28,17 @@ module VarEnv ( -- ** Operations on InScopeSets emptyInScopeSet, mkInScopeSet, delInScopeSet, extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, - modifyInScopeSet, - getInScopeVars, lookupInScope, elemInScopeSet, uniqAway, + getInScopeVars, lookupInScope, lookupInScope_Directly, + unionInScope, elemInScopeSet, uniqAway, -- * The RnEnv2 type RnEnv2, -- ** Operations on RnEnv2s mkRnEnv2, rnBndr2, rnBndrs2, rnOccL, rnOccR, inRnEnvL, inRnEnvR, - rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, extendRnInScopeList, + rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, + addRnInScopeSet, + rnEtaL, rnEtaR, rnInScope, rnInScopeSet, lookupRnInScope, -- * TidyEnv and its operation @@ -66,7 +69,18 @@ import FastString \begin{code} -- | A set of variables that are in scope at some point data InScopeSet = InScope (VarEnv Var) FastInt - -- The Int# is a kind of hash-value used by uniqAway + -- The (VarEnv Var) is just a VarSet. But we write it like + -- this to remind ourselves that you can look up a Var in + -- the InScopeSet. Typically the InScopeSet contains the + -- canonical version of the variable (e.g. with an informative + -- unfolding), so this lookup is useful. + -- + -- INVARIANT: the VarEnv maps (the Unique of) a variable to + -- a variable with the same Uniqua. (This was not + -- the case in the past, when we had a grevious hack + -- mapping var1 to var2. + -- + -- The FastInt is a kind of hash-value used by uniqAway -- For example, it might be the size of the set -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway @@ -94,37 +108,24 @@ extendInScopeSetSet :: InScopeSet -> VarEnv Var -> InScopeSet extendInScopeSetSet (InScope in_scope n) vs = InScope (in_scope `plusVarEnv` vs) (n +# iUnbox (sizeUFM vs)) --- | Replace the first 'Var' with the second in the set of in-scope variables -modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet --- Exploit the fact that the in-scope "set" is really a map --- Make old_v map to new_v --- QUESTION: shouldn't we add a mapping from new_v to new_v as it is presumably now in scope? - MB 08 -modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_scope old_v new_v) (n +# _ILIT(1)) - delInScopeSet :: InScopeSet -> Var -> InScopeSet delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n elemInScopeSet :: Var -> InScopeSet -> Bool elemInScopeSet v (InScope in_scope _) = v `elemVarEnv` in_scope --- | If the given variable was even added to the 'InScopeSet', or if it was the \"from\" argument --- of any 'modifyInScopeSet' operation, returns that variable with all appropriate modifications --- applied to it. Otherwise, return @Nothing@ +-- | Look up a variable the 'InScopeSet'. This lets you map from +-- the variable's identity (unique) to its full value. lookupInScope :: InScopeSet -> Var -> Maybe Var --- It's important to look for a fixed point --- When we see (case x of y { I# v -> ... }) --- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder and --- modifyInScopeSet). --- --- When we lookup up an occurrence of x, we map to y, but then --- we want to look up y in case it has acquired more evaluation information by now. -lookupInScope (InScope in_scope _) v - = go v - where - go v = case lookupVarEnv in_scope v of - Just v' | v == v' -> Just v' -- Reached a fixed point - | otherwise -> go v' - Nothing -> Nothing +lookupInScope (InScope in_scope _) v = lookupVarEnv in_scope v + +lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var +lookupInScope_Directly (InScope in_scope _) uniq + = lookupVarEnv_Directly in_scope uniq + +unionInScope :: InScopeSet -> InScopeSet -> InScopeSet +unionInScope (InScope s1 _) (InScope s2 n2) + = InScope (s1 `plusVarEnv` s2) n2 \end{code} \begin{code} @@ -204,9 +205,10 @@ mkRnEnv2 vars = RV2 { envL = emptyVarEnv , envR = emptyVarEnv , in_scope = vars } -extendRnInScopeList :: RnEnv2 -> [Var] -> RnEnv2 -extendRnInScopeList env vs - = env { in_scope = extendInScopeSetList (in_scope env) vs } +addRnInScopeSet :: RnEnv2 -> VarEnv Var -> RnEnv2 +addRnInScopeSet env vs + | isEmptyVarEnv vs = env + | otherwise = env { in_scope = extendInScopeSetSet (in_scope env) vs } rnInScope :: Var -> RnEnv2 -> Bool rnInScope x env = x `elemInScopeSet` in_scope env @@ -243,36 +245,43 @@ rnBndr2 (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR rnBndrL :: RnEnv2 -> Var -> (RnEnv2, Var) -- ^ Similar to 'rnBndr2' but used when there's a binder on the left --- side only. Useful when eta-expanding +-- side only. rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL = (RV2 { envL = extendVarEnv envL bL new_b - , envR = extendVarEnv envR new_b new_b -- Note [rnBndrLR] + , envR = envR , in_scope = extendInScopeSet in_scope new_b }, new_b) where new_b = uniqAway in_scope bL rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var) -- ^ Similar to 'rnBndr2' but used when there's a binder on the right --- side only. Useful when eta-expanding +-- side only. rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR - = (RV2 { envL = extendVarEnv envL new_b new_b -- Note [rnBndrLR] - , envR = extendVarEnv envR bR new_b + = (RV2 { envR = extendVarEnv envR bR new_b + , envL = envL , in_scope = extendInScopeSet in_scope new_b }, new_b) where new_b = uniqAway in_scope bR --- Note [rnBndrLR] --- ~~~~~~~~~~~~~~~ --- Notice that in rnBndrL, rnBndrR, we extend envR, envL respectively --- with a binding [new_b -> new_b], where new_b is the new binder. --- This is important when doing eta expansion; e.g. matching (\x.M) ~ N --- In effect we switch to (\x'.M) ~ (\x'.N x'), where x' is new_b --- So we must add x' to the env of both L and R. (x' is fresh, so it --- can't capture anything in N.) --- --- If we don't do this, we can get silly matches like --- forall a. \y.a ~ v --- succeeding with [x -> v y], which is bogus of course +rnEtaL :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndrL' but used for eta expansion +-- See Note [Eta expansion] +rnEtaL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL + = (RV2 { envL = extendVarEnv envL bL new_b + , envR = extendVarEnv envR new_b new_b -- Note [Eta expansion] + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bL + +rnEtaR :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but used for eta expansion +-- See Note [Eta expansion] +rnEtaR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR + = (RV2 { envL = extendVarEnv envL new_b new_b -- Note [Eta expansion] + , envR = extendVarEnv envR bR new_b + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bR rnOccL, rnOccR :: RnEnv2 -> Var -> Var -- ^ Look up the renaming of an occurrence in the left or right term @@ -293,6 +302,20 @@ nukeRnEnvL env = env { envL = emptyVarEnv } nukeRnEnvR env = env { envR = emptyVarEnv } \end{code} +Note [Eta expansion] +~~~~~~~~~~~~~~~~~~~~ +When matching + (\x.M) ~ N +we rename x to x' with, where x' is not in scope in +either term. Then we want to behave as if we'd seen + (\x'.M) ~ (\x'.N x') +Since x' isn't in scope in N, the form (\x'. N x') doesn't +capture any variables in N. But we must nevertheless extend +the envR with a binding [x' -> x'], to support the occurs check. +For example, if we don't do this, we can get silly matches like + forall a. (\y.a) ~ v +succeeding with [a -> v y], which is bogus of course. + %************************************************************************ %* * @@ -320,6 +343,7 @@ emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) type VarEnv elt = UniqFM elt type IdEnv elt = VarEnv elt type TyVarEnv elt = VarEnv elt +type CoVarEnv elt = VarEnv elt emptyVarEnv :: VarEnv a mkVarEnv :: [(Var, a)] -> VarEnv a @@ -327,13 +351,17 @@ zipVarEnv :: [Var] -> [a] -> VarEnv a unitVarEnv :: Var -> a -> VarEnv a extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a +extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a +restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a delVarEnvList :: VarEnv a -> [Var] -> VarEnv a delVarEnv :: VarEnv a -> Var -> VarEnv a +minusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a +intersectsVarEnv :: VarEnv a -> VarEnv a -> Bool plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a @@ -354,10 +382,13 @@ elemVarEnv = elemUFM elemVarEnvByKey = elemUFM_Directly extendVarEnv = addToUFM extendVarEnv_C = addToUFM_C +extendVarEnv_Acc = addToUFM_Acc extendVarEnvList = addListToUFM plusVarEnv_C = plusUFM_C delVarEnvList = delListFromUFM delVarEnv = delFromUFM +minusVarEnv = minusUFM +intersectsVarEnv e1 e2 = not (isEmptyVarEnv (e1 `intersectUFM` e2)) plusVarEnv = plusUFM lookupVarEnv = lookupUFM lookupWithDefaultVarEnv = lookupWithDefaultUFM @@ -372,6 +403,10 @@ foldVarEnv = foldUFM lookupVarEnv_Directly = lookupUFM_Directly filterVarEnv_Directly = filterUFM_Directly +restrictVarEnv env vs = filterVarEnv_Directly keep env + where + keep u _ = u `elemVarSetByKey` vs + zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys) lookupVarEnv_NF env id = case lookupVarEnv env id of Just xx -> xx