X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FVarEnv.lhs;h=4c31b24f09218144418782fce9e2d83df30ba241;hb=814d2f506d63f785dbfe33189dde606a06e60285;hp=dba4ec0f5a47d9098cb10643f1157d95c14aeaca;hpb=7d44782fdfab8c280ae8de1846cb40a78b6edb95;p=ghc-hetmet.git diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs index dba4ec0..4c31b24 100644 --- a/compiler/basicTypes/VarEnv.lhs +++ b/compiler/basicTypes/VarEnv.lhs @@ -1,7 +1,7 @@ - +% +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section{@VarEnvs@: Variable environments} \begin{code} module VarEnv ( @@ -20,31 +20,30 @@ module VarEnv ( -- InScopeSet InScopeSet, emptyInScopeSet, mkInScopeSet, delInScopeSet, - extendInScopeSet, extendInScopeSetList, modifyInScopeSet, + 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, lookupRnInScope, + rnInScope, rnInScopeSet, lookupRnInScope, -- TidyEnvs TidyEnv, emptyTidyEnv ) where -#include "HsVersions.h" - -import OccName ( TidyOccEnv, emptyTidyOccEnv ) -import Var ( Var, setVarUnique ) +import OccName +import Var import VarSet -import UniqFM -import Unique ( Unique, deriveUnique, getUnique ) -import Util ( zipEqual, foldl2 ) -import Maybes ( orElse ) -import StaticFlags( opt_PprStyle_Debug ) +import UniqFM +import Unique +import Util +import Maybes import Outputable import FastTypes +import StaticFlags +import FastString \end{code} @@ -61,38 +60,39 @@ data InScopeSet = InScope (VarEnv Var) FastInt -- 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 + ppr (InScope s _) = ptext (sLit "InScope") <+> ppr s emptyInScopeSet :: InScopeSet -emptyInScopeSet = InScope emptyVarSet 1# +emptyInScopeSet = InScope emptyVarSet (_ILIT(1)) getInScopeVars :: InScopeSet -> VarEnv Var getInScopeVars (InScope vs _) = vs mkInScopeSet :: VarEnv Var -> InScopeSet -mkInScopeSet in_scope = InScope in_scope 1# +mkInScopeSet in_scope = InScope in_scope (_ILIT(1)) extendInScopeSet :: InScopeSet -> Var -> InScopeSet -extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# 1#) +extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# _ILIT(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)) +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 +# 1#) +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 n) = v `elemVarEnv` in_scope +elemInScopeSet v (InScope in_scope _) = v `elemVarEnv` in_scope lookupInScope :: InScopeSet -> Var -> Maybe Var -- It's important to look for a fixed point @@ -100,7 +100,7 @@ lookupInScope :: InScopeSet -> Var -> Maybe Var -- 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 +lookupInScope (InScope in_scope _) v = go v where go v = case lookupVarEnv in_scope v of @@ -122,20 +122,16 @@ uniqAway in_scope var uniqAway' :: InScopeSet -> Var -> Var -- This one *always* makes up a new variable uniqAway' (InScope set n) var - = try 1# + = try (_ILIT(1)) where orig_unique = getUnique var try k -#ifdef DEBUG - | k ># 1000# + | debugIsOn && (k ># _ILIT(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# + | uniq `elemVarSetByKey` set = try (k +# _ILIT(1)) + | debugIsOn && opt_PprStyle_Debug && (k ># _ILIT(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)) @@ -191,6 +187,9 @@ extendRnInScopeList env vs rnInScope :: Var -> RnEnv2 -> Bool rnInScope x env = x `elemInScopeSet` in_scope env +rnInScopeSet :: RnEnv2 -> InScopeSet +rnInScopeSet = in_scope + rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2 -- Arg lists must be of equal length rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR @@ -221,21 +220,33 @@ rnBndr2 (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR 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 + , envR = extendVarEnv envR new_b new_b -- Note [rnBndrLR] , in_scope = extendInScopeSet in_scope new_b }, new_b) where - new_b | not (bL `elemInScopeSet` in_scope) = bL - | otherwise = uniqAway' in_scope bL + new_b = uniqAway in_scope bL rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR - = (RV2 { envL = envL + = (RV2 { envL = extendVarEnv envL new_b new_b -- Note [rnBndrLR] , 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 + 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 rnOccL, rnOccR :: RnEnv2 -> Var -> Var -- Look up the renaming of an occurrence in the left or right term @@ -336,7 +347,9 @@ 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 } +lookupVarEnv_NF env id = case lookupVarEnv env id of + Just xx -> xx + Nothing -> panic "lookupVarEnv_NF: Nothing" \end{code} @modifyVarEnv@: Look up a thing in the VarEnv, @@ -348,6 +361,7 @@ modifyVarEnv mangle_fn env key Nothing -> env Just xx -> extendVarEnv env key (mangle_fn xx) +modifyVarEnv_Directly :: (a -> a) -> UniqFM a -> Unique -> UniqFM a modifyVarEnv_Directly mangle_fn env key = case (lookupUFM_Directly env key) of Nothing -> env