2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section{@VarEnvs@: Variable environments}
8 VarEnv, IdEnv, TyVarEnv,
9 emptyVarEnv, unitVarEnv, mkVarEnv,
10 elemVarEnv, varEnvElts, varEnvKeys,
11 extendVarEnv, extendVarEnv_C, extendVarEnvList,
12 plusVarEnv, plusVarEnv_C,
13 delVarEnvList, delVarEnv,
14 lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv,
16 modifyVarEnv, modifyVarEnv_Directly,
17 isEmptyVarEnv, foldVarEnv,
18 lookupVarEnv_Directly,
19 filterVarEnv_Directly,
22 InScopeSet, emptyInScopeSet, mkInScopeSet, delInScopeSet,
23 extendInScopeSet, extendInScopeSetList, modifyInScopeSet,
24 getInScopeVars, lookupInScope, elemInScopeSet, uniqAway,
27 -- RnEnv2 and its operations
28 RnEnv2, mkRnEnv2, rnBndr2, rnBndrs2, rnOccL, rnOccR, inRnEnvL, inRnEnvR,
29 rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR,
35 #include "HsVersions.h"
37 import OccName ( TidyOccEnv, emptyTidyOccEnv )
38 import Var ( Var, setVarUnique )
41 import Unique ( Unique, deriveUnique, getUnique )
42 import Util ( zipEqual, foldl2 )
43 import Maybes ( orElse, isJust )
44 import StaticFlags( opt_PprStyle_Debug )
50 %************************************************************************
54 %************************************************************************
57 data InScopeSet = InScope (VarEnv Var) FastInt
58 -- The Int# is a kind of hash-value used by uniqAway
59 -- For example, it might be the size of the set
60 -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway
62 instance Outputable InScopeSet where
63 ppr (InScope s i) = ptext SLIT("InScope") <+> ppr s
65 emptyInScopeSet :: InScopeSet
66 emptyInScopeSet = InScope emptyVarSet 1#
68 getInScopeVars :: InScopeSet -> VarEnv Var
69 getInScopeVars (InScope vs _) = vs
71 mkInScopeSet :: VarEnv Var -> InScopeSet
72 mkInScopeSet in_scope = InScope in_scope 1#
74 extendInScopeSet :: InScopeSet -> Var -> InScopeSet
75 extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# 1#)
77 extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
78 extendInScopeSetList (InScope in_scope n) vs
79 = InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs)
80 (n +# iUnbox (length vs))
82 modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet
83 -- Exploit the fact that the in-scope "set" is really a map
84 -- Make old_v map to new_v
85 modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_scope old_v new_v) (n +# 1#)
87 delInScopeSet :: InScopeSet -> Var -> InScopeSet
88 delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n
90 mapInScopeSet :: (Var -> Var) -> InScopeSet -> InScopeSet
91 mapInScopeSet f (InScope in_scope n) = InScope (mapVarEnv f in_scope) n
93 elemInScopeSet :: Var -> InScopeSet -> Bool
94 elemInScopeSet v (InScope in_scope n) = v `elemVarEnv` in_scope
96 lookupInScope :: InScopeSet -> Var -> Maybe Var
97 -- It's important to look for a fixed point
98 -- When we see (case x of y { I# v -> ... })
99 -- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder).
100 -- When we lookup up an occurrence of x, we map to y, but then
101 -- we want to look up y in case it has acquired more evaluation information by now.
102 lookupInScope (InScope in_scope n) v
105 go v = case lookupVarEnv in_scope v of
106 Just v' | v == v' -> Just v' -- Reached a fixed point
112 uniqAway :: InScopeSet -> Var -> Var
113 -- (uniqAway in_scope v) finds a unique that is not used in the
114 -- in-scope set, and gives that to v. It starts with v's current unique, of course,
115 -- in the hope that it won't have to change it, and thereafter uses a combination
116 -- of that and the hash-code found in the in-scope set
117 uniqAway in_scope var
118 | var `elemInScopeSet` in_scope = uniqAway' in_scope var -- Make a new one
119 | otherwise = var -- Nothing to do
121 uniqAway' :: InScopeSet -> Var -> Var
122 -- This one *always* makes up a new variable
123 uniqAway' (InScope set n) var
126 orig_unique = getUnique var
130 = pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
132 | uniq `elemVarSetByKey` set = try (k +# 1#)
134 | opt_PprStyle_Debug && k ># 3#
135 = pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
136 setVarUnique var uniq
138 | otherwise = setVarUnique var uniq
140 uniq = deriveUnique orig_unique (iBox (n *# k))
144 %************************************************************************
148 %************************************************************************
150 When we are comparing (or matching) types or terms, we are faced with
151 "going under" corresponding binders. E.g. when comparing
154 Basically we want to rename [x->y] or [y->x], but there are lots of
155 things we must be careful of. In particular, x might be free in e2, or
156 y in e1. So the idea is that we come up with a fresh binder that is free
157 in neither, and rename x and y respectively. That means we must maintain
158 a) a renaming for the left-hand expression
159 b) a renaming for the right-hand expressions
162 Furthermore, when matching, we want to be able to have an 'occurs check',
165 matching with f->y. So for each expression we want to know that set of
166 locally-bound variables. That is precisely the domain of the mappings (a)
167 and (b), but we must ensure that we always extend the mappings as we go in.
172 = RV2 { envL :: VarEnv Var -- Renaming for Left term
173 , envR :: VarEnv Var -- Renaming for Right term
174 , in_scope :: InScopeSet } -- In scope in left or right terms
176 -- The renamings envL and envR are *guaranteed* to contain a binding
177 -- for every variable bound as we go into the term, even if it is not
178 -- renamed. That way we can ask what variables are locally bound
179 -- (inRnEnvL, inRnEnvR)
181 mkRnEnv2 :: InScopeSet -> RnEnv2
182 mkRnEnv2 vars = RV2 { envL = emptyVarEnv
186 rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2
187 -- Arg lists must be of equal length
188 rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR
190 rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2
191 -- (rnBndr2 env bL bR) go under a binder bL in the Left term 1,
192 -- and binder bR in the Right term
193 -- It finds a new binder, new_b,
194 -- and returns an environment mapping bL->new_b and bR->new_b resp.
195 rnBndr2 (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR
196 = RV2 { envL = extendVarEnv envL bL new_b -- See Note
197 , envR = extendVarEnv envR bR new_b -- [Rebinding]
198 , in_scope = extendInScopeSet in_scope new_b }
200 -- Find a new binder not in scope in either term
201 new_b | not (bL `elemInScopeSet` in_scope) = bL
202 | not (bR `elemInScopeSet` in_scope) = bR
203 | otherwise = uniqAway' in_scope bL
206 -- If the new var is the same as the old one, note that
207 -- the extendVarEnv *deletes* any current renaming
208 -- E.g. (\x. \x. ...) ~ (\y. \z. ...)
210 -- Inside \x \y { [x->y], [y->y], {y} }
211 -- \x \z { [x->x], [y->y, z->x], {y,x} }
213 rnBndrL, rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var)
214 -- Used when there's a binder on one side or the other only
215 -- Useful when eta-expanding
216 rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL
217 = (RV2 { envL = extendVarEnv envL bL new_b
219 , in_scope = extendInScopeSet in_scope new_b }, new_b)
221 new_b | not (bL `elemInScopeSet` in_scope) = bL
222 | otherwise = uniqAway' in_scope bL
224 rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR
226 , envR = extendVarEnv envR bR new_b
227 , in_scope = extendInScopeSet in_scope new_b }, new_b)
229 new_b | not (bR `elemInScopeSet` in_scope) = bR
230 | otherwise = uniqAway' in_scope bR
232 rnOccL, rnOccR :: RnEnv2 -> Var -> Var
233 -- Look up the renaming of an occurrence in the left or right term
234 rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v
235 rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v
237 inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool
238 -- Tells whether a variable is locally bound
239 inRnEnvL (RV2 { envL = env }) v = isJust (lookupVarEnv env v)
240 inRnEnvR (RV2 { envR = env }) v = isJust (lookupVarEnv env v)
242 nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2
243 nukeRnEnvL env = env { envL = emptyVarEnv }
244 nukeRnEnvR env = env { envR = emptyVarEnv }
248 %************************************************************************
252 %************************************************************************
254 When tidying up print names, we keep a mapping of in-scope occ-names
255 (the TidyOccEnv) and a Var-to-Var of the current renamings.
258 type TidyEnv = (TidyOccEnv, VarEnv Var)
260 emptyTidyEnv :: TidyEnv
261 emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv)
265 %************************************************************************
267 \subsection{@VarEnv@s}
269 %************************************************************************
272 type VarEnv elt = UniqFM elt
273 type IdEnv elt = VarEnv elt
274 type TyVarEnv elt = VarEnv elt
276 emptyVarEnv :: VarEnv a
277 mkVarEnv :: [(Var, a)] -> VarEnv a
278 zipVarEnv :: [Var] -> [a] -> VarEnv a
279 unitVarEnv :: Var -> a -> VarEnv a
280 extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a
281 extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a
282 plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a
283 extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a
285 lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a
286 filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a
287 delVarEnvList :: VarEnv a -> [Var] -> VarEnv a
288 delVarEnv :: VarEnv a -> Var -> VarEnv a
289 plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
290 mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b
291 modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a
292 varEnvElts :: VarEnv a -> [a]
293 varEnvKeys :: VarEnv a -> [Unique]
295 isEmptyVarEnv :: VarEnv a -> Bool
296 lookupVarEnv :: VarEnv a -> Var -> Maybe a
297 lookupVarEnv_NF :: VarEnv a -> Var -> a
298 lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a
299 elemVarEnv :: Var -> VarEnv a -> Bool
300 foldVarEnv :: (a -> b -> b) -> b -> VarEnv a -> b
305 extendVarEnv = addToUFM
306 extendVarEnv_C = addToUFM_C
307 extendVarEnvList = addListToUFM
308 plusVarEnv_C = plusUFM_C
309 delVarEnvList = delListFromUFM
310 delVarEnv = delFromUFM
312 lookupVarEnv = lookupUFM
313 lookupWithDefaultVarEnv = lookupWithDefaultUFM
316 emptyVarEnv = emptyUFM
320 isEmptyVarEnv = isNullUFM
322 lookupVarEnv_Directly = lookupUFM_Directly
323 filterVarEnv_Directly = filterUFM_Directly
325 zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys)
326 lookupVarEnv_NF env id = case (lookupVarEnv env id) of { Just xx -> xx }
329 @modifyVarEnv@: Look up a thing in the VarEnv,
330 then mash it with the modify function, and put it back.
333 modifyVarEnv mangle_fn env key
334 = case (lookupVarEnv env key) of
336 Just xx -> extendVarEnv env key (mangle_fn xx)
338 modifyVarEnv_Directly mangle_fn env key
339 = case (lookupUFM_Directly env key) of
341 Just xx -> addToUFM_Directly env key (mangle_fn xx)