X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FVarEnv.lhs;h=bfeecdc923d41925ff3e2d69d12a03f558339913;hb=ac10f8408520a30e8437496d320b8b86afda2e8f;hp=f8783f4e1bf990eb79950a182fc2d0acbc258c6d;hpb=77a8c0dbd5c5ad90fe483cb9ddc2b6ef36d3f4d8;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/VarEnv.lhs b/ghc/compiler/basicTypes/VarEnv.lhs index f8783f4..bfeecdc 100644 --- a/ghc/compiler/basicTypes/VarEnv.lhs +++ b/ghc/compiler/basicTypes/VarEnv.lhs @@ -7,101 +7,258 @@ module VarEnv ( VarEnv, IdEnv, TyVarEnv, emptyVarEnv, unitVarEnv, mkVarEnv, - elemVarEnv, rngVarEnv, - extendVarEnv, extendVarEnvList, + elemVarEnv, varEnvElts, varEnvKeys, + extendVarEnv, extendVarEnv_C, extendVarEnvList, plusVarEnv, plusVarEnv_C, delVarEnvList, delVarEnv, lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, mapVarEnv, zipVarEnv, modifyVarEnv, modifyVarEnv_Directly, - isEmptyVarEnv, foldVarEnv, + isEmptyVarEnv, foldVarEnv, + elemVarEnvByKey, lookupVarEnv_Directly, + filterVarEnv_Directly, - -- TidyEnvs - TidyEnv, emptyTidyEnv, + -- InScopeSet + InScopeSet, emptyInScopeSet, mkInScopeSet, delInScopeSet, + extendInScopeSet, extendInScopeSetList, modifyInScopeSet, + getInScopeVars, lookupInScope, elemInScopeSet, uniqAway, + mapInScopeSet, + + -- RnEnv2 and its operations + RnEnv2, mkRnEnv2, rnBndr2, rnBndrs2, rnOccL, rnOccR, inRnEnvL, inRnEnvR, + rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, - -- SubstEnvs - SubstEnv, TyVarSubstEnv, SubstResult(..), - emptySubstEnv, - mkSubstEnv, lookupSubstEnv, extendSubstEnv, extendSubstEnvList, - delSubstEnv, noTypeSubst, isEmptySubstEnv + -- TidyEnvs + TidyEnv, emptyTidyEnv ) where #include "HsVersions.h" -import {-# SOURCE #-} CoreSyn( CoreExpr ) -import {-# SOURCE #-} TypeRep( Type ) - -import BasicTypes ( OccInfo ) import OccName ( TidyOccEnv, emptyTidyOccEnv ) -import Var ( Var, Id ) +import Var ( Var, setVarUnique ) +import VarSet import UniqFM -import Util ( zipEqual ) +import Unique ( Unique, deriveUnique, getUnique ) +import Util ( zipEqual, foldl2 ) +import Maybes ( orElse, isJust ) +import StaticFlags( opt_PprStyle_Debug ) +import Outputable +import FastTypes \end{code} %************************************************************************ %* * -\subsection{Tidying} + In-scope sets %* * %************************************************************************ -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} +data InScopeSet = InScope (VarEnv Var) FastInt + -- The Int# 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 + +instance Outputable InScopeSet where + ppr (InScope s i) = ptext SLIT("InScope") <+> ppr s + +emptyInScopeSet :: InScopeSet +emptyInScopeSet = InScope emptyVarSet 1# + +getInScopeVars :: InScopeSet -> VarEnv Var +getInScopeVars (InScope vs _) = vs + +mkInScopeSet :: VarEnv Var -> InScopeSet +mkInScopeSet in_scope = InScope in_scope 1# + +extendInScopeSet :: InScopeSet -> Var -> InScopeSet +extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# 1#) + +extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet +extendInScopeSetList (InScope in_scope n) vs + = InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs) + (n +# iUnbox (length 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 +# 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 n) = v `elemVarEnv` in_scope + +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 n) 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 +\end{code} \begin{code} -type TidyEnv = (TidyOccEnv, VarEnv Var) -emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) +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 +uniqAway in_scope var + | var `elemInScopeSet` in_scope = uniqAway' in_scope var -- Make a new one + | otherwise = var -- Nothing to do + +uniqAway' :: InScopeSet -> Var -> Var +-- This one *always* makes up a new variable +uniqAway' (InScope set n) var + = try 1# + where + orig_unique = getUnique var + try k +#ifdef DEBUG + | k ># 1000# + = pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) +#endif + | uniq `elemVarSetByKey` set = try (k +# 1#) +#ifdef DEBUG + | opt_PprStyle_Debug && k ># 3# + = pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) + setVarUnique var uniq +#endif + | otherwise = setVarUnique var uniq + where + uniq = deriveUnique orig_unique (iBox (n *# k)) \end{code} %************************************************************************ %* * -\subsection{Substitution environments} + Dual renaming %* * %************************************************************************ -\begin{code} - -noTys :: SubstResult -> Bool -> Bool -noTys (DoneTy ty) no_tys = False -noTys other no_tys = no_tys - -data SubstEnv = SE (VarEnv SubstResult) - Bool -- True => definitely no type substitutions in the env +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 -noTypeSubst :: SubstEnv -> Bool -noTypeSubst (SE _ nt) = nt +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 -type TyVarSubstEnv = SubstEnv -- of the form (DoneTy ty) *only* +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. -data SubstResult - = DoneEx CoreExpr -- Completed term - | DoneId Id OccInfo -- Completed term variable, with occurrence info; only - -- used by the simplifier - | DoneTy Type -- Completed type - | ContEx SubstEnv CoreExpr -- A suspended substitution -emptySubstEnv :: SubstEnv -emptySubstEnv = SE emptyVarEnv True - -isEmptySubstEnv :: SubstEnv -> Bool -isEmptySubstEnv (SE s _) = isEmptyVarEnv s +\begin{code} +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 + +-- The renamings envL and envR are *guaranteed* to contain a binding +-- for every variable bound as we go into the term, even if it is not +-- renamed. That way we can ask what variables are locally bound +-- (inRnEnvL, inRnEnvR) + +mkRnEnv2 :: InScopeSet -> RnEnv2 +mkRnEnv2 vars = RV2 { envL = emptyVarEnv + , envR = emptyVarEnv + , in_scope = vars } + +rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2 +-- Arg 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 (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] + , in_scope = extendInScopeSet in_scope new_b } + where + -- Find a new binder not in scope in either term + new_b | not (bL `elemInScopeSet` in_scope) = bL + | not (bR `elemInScopeSet` in_scope) = bR + | otherwise = uniqAway' in_scope bL + + -- Note [Rebinding] + -- If the new var is the same as the old one, note that + -- the extendVarEnv *deletes* any current renaming + -- E.g. (\x. \x. ...) ~ (\y. \z. ...) + -- + -- 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 (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL + = (RV2 { envL = extendVarEnv envL bL new_b + , envR = envR + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b | not (bL `elemInScopeSet` in_scope) = bL + | otherwise = uniqAway' in_scope bL + +rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR + = (RV2 { envL = envL + , envR = extendVarEnv envR bR new_b + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b | not (bR `elemInScopeSet` in_scope) = bR + | otherwise = uniqAway' in_scope bR + +rnOccL, rnOccR :: RnEnv2 -> Var -> Var +-- 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 +inRnEnvL (RV2 { envL = env }) v = isJust (lookupVarEnv env v) +inRnEnvR (RV2 { envR = env }) v = isJust (lookupVarEnv env v) + +nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2 +nukeRnEnvL env = env { envL = emptyVarEnv } +nukeRnEnvR env = env { envR = emptyVarEnv } +\end{code} -lookupSubstEnv :: SubstEnv -> Var -> Maybe SubstResult -lookupSubstEnv (SE s _) v = lookupVarEnv s v -extendSubstEnv :: SubstEnv -> Var -> SubstResult -> SubstEnv -extendSubstEnv (SE s nt) v r = SE (extendVarEnv s v r) (noTys r nt) +%************************************************************************ +%* * + Tidying +%* * +%************************************************************************ -mkSubstEnv :: [Var] -> [SubstResult] -> SubstEnv -mkSubstEnv bs vs = extendSubstEnvList emptySubstEnv bs vs +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. -extendSubstEnvList :: SubstEnv -> [Var] -> [SubstResult] -> SubstEnv -extendSubstEnvList env [] [] = env -extendSubstEnvList (SE env nt) (b:bs) (r:rs) = extendSubstEnvList (SE (extendVarEnv env b r) (noTys r nt)) bs rs +\begin{code} +type TidyEnv = (TidyOccEnv, VarEnv Var) -delSubstEnv :: SubstEnv -> Var -> SubstEnv -delSubstEnv (SE s nt) v = SE (delVarEnv s v) nt +emptyTidyEnv :: TidyEnv +emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) \end{code} @@ -121,27 +278,34 @@ mkVarEnv :: [(Var, a)] -> VarEnv a 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 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 delVarEnvList :: VarEnv a -> [Var] -> VarEnv a delVarEnv :: VarEnv a -> Var -> VarEnv a 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 -rngVarEnv :: VarEnv a -> [a] +varEnvElts :: VarEnv a -> [a] +varEnvKeys :: VarEnv a -> [Unique] isEmptyVarEnv :: VarEnv a -> Bool lookupVarEnv :: VarEnv a -> Var -> Maybe a lookupVarEnv_NF :: VarEnv a -> Var -> a lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a elemVarEnv :: Var -> VarEnv a -> Bool +elemVarEnvByKey :: Unique -> VarEnv a -> Bool foldVarEnv :: (a -> b -> b) -> b -> VarEnv a -> b \end{code} \begin{code} elemVarEnv = elemUFM +elemVarEnvByKey = elemUFM_Directly extendVarEnv = addToUFM +extendVarEnv_C = addToUFM_C extendVarEnvList = addListToUFM plusVarEnv_C = plusUFM_C delVarEnvList = delListFromUFM @@ -152,13 +316,16 @@ lookupWithDefaultVarEnv = lookupWithDefaultUFM mapVarEnv = mapUFM mkVarEnv = listToUFM emptyVarEnv = emptyUFM -rngVarEnv = eltsUFM +varEnvElts = eltsUFM +varEnvKeys = keysUFM unitVarEnv = unitUFM isEmptyVarEnv = isNullUFM foldVarEnv = foldUFM +lookupVarEnv_Directly = lookupUFM_Directly +filterVarEnv_Directly = filterUFM_Directly -zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys) -lookupVarEnv_NF env id = case (lookupVarEnv env id) of { Just xx -> xx } +zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys) +lookupVarEnv_NF env id = case (lookupVarEnv env id) of { Just xx -> xx } \end{code} @modifyVarEnv@: Look up a thing in the VarEnv,