X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FVarEnv.lhs;h=bb988b259159394899c5ed8d3948bde424ee4e9c;hb=30c122df62ec75f9ed7f392f24c2925675bf1d06;hp=e59c800c1ea710aeb780ae2a2b3f85c0b88e8528;hpb=d5bba9ee196f64a077e922680b16fe6f28fb79db;p=ghc-hetmet.git diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs index e59c800..bb988b2 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 ( @@ -28,7 +28,7 @@ module VarEnv ( -- 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 @@ -36,16 +36,17 @@ module VarEnv ( #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} @@ -62,19 +63,19 @@ 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 @@ -88,7 +89,7 @@ extendInScopeSetSet (InScope in_scope n) 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 @@ -97,7 +98,7 @@ 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 @@ -105,7 +106,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 @@ -127,20 +128,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)) @@ -196,6 +193,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 @@ -226,21 +226,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 @@ -341,7 +353,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, @@ -353,6 +367,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