X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FVarEnv.lhs;h=fca625692f47ef9365d5503524b6d4f70fc537a1;hp=8274661be61b55e05aee3cee1e9d1fce704ebbfe;hb=d9a655dad8e013e41c74dca98fb86c4ed6f29879;hpb=a5eb4495c007e6025476c2bdab83e3c2e0f30c3f diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs index 8274661..fca6256 100644 --- a/compiler/basicTypes/VarEnv.lhs +++ b/compiler/basicTypes/VarEnv.lhs @@ -5,33 +5,45 @@ \begin{code} module VarEnv ( - VarEnv, IdEnv, TyVarEnv, + -- * Var, Id and TyVar environments (maps) + 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, - -- InScopeSet - InScopeSet, emptyInScopeSet, mkInScopeSet, delInScopeSet, + -- * The InScopeSet type + InScopeSet, + + -- ** Operations on InScopeSets + emptyInScopeSet, mkInScopeSet, delInScopeSet, extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, - modifyInScopeSet, - getInScopeVars, lookupInScope, elemInScopeSet, uniqAway, - mapInScopeSet, - - -- RnEnv2 and its operations - RnEnv2, mkRnEnv2, rnBndr2, rnBndrs2, rnOccL, rnOccR, inRnEnvL, inRnEnvR, - rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, extendRnInScopeList, - rnInScope, rnInScopeSet, lookupRnInScope, - - -- TidyEnvs - TidyEnv, emptyTidyEnv + 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, + addRnInScopeSet, + rnEtaL, rnEtaR, + rnInScope, rnInScopeSet, lookupRnInScope, + + -- * TidyEnv and its operation + TidyEnv, + emptyTidyEnv ) where import OccName @@ -55,8 +67,20 @@ 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 @@ -84,41 +108,33 @@ extendInScopeSetSet :: InScopeSet -> VarEnv Var -> InScopeSet extendInScopeSetSet (InScope in_scope n) vs = InScope (in_scope `plusVarEnv` vs) (n +# iUnbox (sizeUFM vs)) -modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet --- Exploit the fact that the in-scope "set" is really a map --- Make old_v map to new_v -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 -mapInScopeSet :: (Var -> Var) -> InScopeSet -> InScopeSet -mapInScopeSet f (InScope in_scope n) = InScope (mapVarEnv f in_scope) n - elemInScopeSet :: Var -> InScopeSet -> Bool elemInScopeSet v (InScope in_scope _) = v `elemVarEnv` in_scope +-- | 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). --- 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} +-- | @uniqAway in_scope v@ finds a unique that is not used in the +-- in-scope set, and gives that to v. uniqAway :: InScopeSet -> Var -> Var --- (uniqAway in_scope v) finds a unique that is not used in the --- in-scope set, and gives that to v. It starts with v's current unique, of course, --- in the hope that it won't have to change it, and thereafter uses a combination --- of that and the hash-code found in the in-scope set +-- It starts with v's current unique, of course, in the hope that it won't +-- have to change, and thereafter uses a combination of that and the hash-code +-- found in the in-scope set uniqAway in_scope var | var `elemInScopeSet` in_scope = uniqAway' in_scope var -- Make a new one | otherwise = var -- Nothing to do @@ -141,35 +157,40 @@ uniqAway' (InScope set n) var uniq = deriveUnique orig_unique (iBox (n *# k)) \end{code} - %************************************************************************ %* * Dual renaming %* * %************************************************************************ -When we are comparing (or matching) types or terms, we are faced with -"going under" corresponding binders. E.g. when comparing - \x. e1 ~ \y. e2 - -Basically we want to rename [x->y] or [y->x], but there are lots of -things we must be careful of. In particular, x might be free in e2, or -y in e1. So the idea is that we come up with a fresh binder that is free -in neither, and rename x and y respectively. That means we must maintain - a) a renaming for the left-hand expression - b) a renaming for the right-hand expressions - c) an in-scope set - -Furthermore, when matching, we want to be able to have an 'occurs check', -to prevent - \x. f ~ \y. y -matching with f->y. So for each expression we want to know that set of -locally-bound variables. That is precisely the domain of the mappings (a) -and (b), but we must ensure that we always extend the mappings as we go in. - - \begin{code} -data RnEnv2 +-- | When we are comparing (or matching) types or terms, we are faced with +-- \"going under\" corresponding binders. E.g. when comparing: +-- +-- > \x. e1 ~ \y. e2 +-- +-- Basically we want to rename [@x@ -> @y@] or [@y@ -> @x@], but there are lots of +-- things we must be careful of. In particular, @x@ might be free in @e2@, or +-- y in @e1@. So the idea is that we come up with a fresh binder that is free +-- in neither, and rename @x@ and @y@ respectively. That means we must maintain: +-- +-- 1. A renaming for the left-hand expression +-- +-- 2. A renaming for the right-hand expressions +-- +-- 3. An in-scope set +-- +-- Furthermore, when matching, we want to be able to have an 'occurs check', +-- to prevent: +-- +-- > \x. f ~ \y. y +-- +-- matching with [@f@ -> @y@]. So for each expression we want to know that set of +-- locally-bound variables. That is precisely the domain of the mappings 1. +-- and 2., but we must ensure that we always extend the mappings as we go in. +-- +-- All of this information is bundled up in the 'RnEnv2' +data RnEnv2 = RV2 { envL :: VarEnv Var -- Renaming for Left term , envR :: VarEnv Var -- Renaming for Right term , in_scope :: InScopeSet } -- In scope in left or right terms @@ -184,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 @@ -195,14 +217,14 @@ rnInScopeSet :: RnEnv2 -> InScopeSet rnInScopeSet = in_scope rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2 --- Arg lists must be of equal length +-- ^ Applies 'rnBndr2' to several variables: the two variable lists must be of equal length rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2 --- (rnBndr2 env bL bR) go under a binder bL in the Left term 1, --- and binder bR in the Right term --- It finds a new binder, new_b, --- and returns an environment mapping bL->new_b and bR->new_b resp. +-- ^ @rnBndr2 env bL bR@ goes under a binder @bL@ in the Left term, +-- and binder @bR@ in the Right term. +-- It finds a new binder, @new_b@, +-- and returns an environment mapping @bL -> new_b@ and @bR -> new_b@ rnBndr2 (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR = RV2 { envL = extendVarEnv envL bL new_b -- See Note , envR = extendVarEnv envR bR new_b -- [Rebinding] @@ -221,44 +243,53 @@ rnBndr2 (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR -- Inside \x \y { [x->y], [y->y], {y} } -- \x \z { [x->x], [y->y, z->x], {y,x} } -rnBndrL, rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var) --- Used when there's a binder on one side or the other only --- Useful when eta-expanding --- +rnBndrL :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but used when there's a binder on the left +-- 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. 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 +-- ^ Look up the renaming of an occurrence in the left or right term rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool --- Tells whether a variable is locally bound +-- ^ Tells whether a variable is locally bound inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env @@ -266,10 +297,25 @@ lookupRnInScope :: RnEnv2 -> Var -> Var lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2 +-- ^ Wipe the left or right side renaming 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. + %************************************************************************ %* * @@ -277,10 +323,9 @@ nukeRnEnvR env = env { envR = emptyVarEnv } %* * %************************************************************************ -When tidying up print names, we keep a mapping of in-scope occ-names -(the TidyOccEnv) and a Var-to-Var of the current renamings. - \begin{code} +-- | When tidying up print names, we keep a mapping of in-scope occ-names +-- (the 'TidyOccEnv') and a Var-to-Var of the current renamings type TidyEnv = (TidyOccEnv, VarEnv Var) emptyTidyEnv :: TidyEnv @@ -298,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 @@ -305,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 @@ -332,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 @@ -350,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