-
+%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section{@VarEnvs@: Variable environments}
\begin{code}
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
#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}
-- 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
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 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
-- 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
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))
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
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
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,
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
projects / ghc-hetmet.git / blobdiff