VarEnv.lhs 14.7 KB
Newer Older
Simon Marlow's avatar
Simon Marlow committed
1
2
%
% (c) The University of Glasgow 2006
3
4
5
6
7
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%

\begin{code}
module VarEnv (
batterseapower's avatar
batterseapower committed
8
        -- * Var, Id and TyVar environments (maps)
9
	VarEnv, IdEnv, TyVarEnv,
batterseapower's avatar
batterseapower committed
10
11
	
	-- ** Manipulating these environments
12
	emptyVarEnv, unitVarEnv, mkVarEnv,
13
	elemVarEnv, varEnvElts, varEnvKeys,
14
	extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnvList,
15
16
	plusVarEnv, plusVarEnv_C,
	delVarEnvList, delVarEnv,
17
        minusVarEnv, intersectsVarEnv,
18
	lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv,
19
20
	mapVarEnv, zipVarEnv,
	modifyVarEnv, modifyVarEnv_Directly,
21
	isEmptyVarEnv, foldVarEnv, 
22
	elemVarEnvByKey, lookupVarEnv_Directly,
23
	filterVarEnv_Directly, restrictVarEnv,
24

batterseapower's avatar
batterseapower committed
25
26
27
28
29
	-- * The InScopeSet type
	InScopeSet, 
	
	-- ** Operations on InScopeSets
	emptyInScopeSet, mkInScopeSet, delInScopeSet,
30
	extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, 
31
	getInScopeVars, lookupInScope, lookupInScope_Directly, 
32
        unionInScope, elemInScopeSet, uniqAway, 
33

batterseapower's avatar
batterseapower committed
34
35
36
37
38
39
	-- * The RnEnv2 type
	RnEnv2, 
	
	-- ** Operations on RnEnv2s
	mkRnEnv2, rnBndr2, rnBndrs2, rnOccL, rnOccR, inRnEnvL, inRnEnvR,
	rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, extendRnInScopeList,
40
        rnEtaL, rnEtaR,
batterseapower's avatar
batterseapower committed
41
42
43
44
45
	rnInScope, rnInScopeSet, lookupRnInScope,

	-- * TidyEnv and its operation
	TidyEnv, 
	emptyTidyEnv
46
47
    ) where

Simon Marlow's avatar
Simon Marlow committed
48
49
import OccName
import Var
50
import VarSet
51
import UniqFM
Simon Marlow's avatar
Simon Marlow committed
52
53
54
import Unique
import Util
import Maybes
55
56
import Outputable
import FastTypes
57
import StaticFlags
58
import FastString
59
60
61
\end{code}


62
63
%************************************************************************
%*									*
64
		In-scope sets
65
66
67
68
%*									*
%************************************************************************

\begin{code}
batterseapower's avatar
batterseapower committed
69
-- | A set of variables that are in scope at some point
70
data InScopeSet = InScope (VarEnv Var) FastInt
71
72
73
74
75
76
77
78
79
80
81
82
	-- The (VarEnv Var) is just a VarSet.  But we write it like
	-- this to remind ourselves that you can look up a Var in 
	-- the InScopeSet. Typically the InScopeSet contains the
	-- canonical version of the variable (e.g. with an informative
	-- unfolding), so this lookup is useful.
	--
	-- INVARIANT: the VarEnv maps (the Unique of) a variable to 
	--	      a variable with the same Uniqua.  (This was not
	--	      the case in the past, when we had a grevious hack
	--	      mapping var1 to var2.	
	-- 
	-- The FastInt is a kind of hash-value used by uniqAway
83
84
85
86
	-- 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
Ian Lynagh's avatar
Ian Lynagh committed
87
  ppr (InScope s _) = ptext (sLit "InScope") <+> ppr s
88
89

emptyInScopeSet :: InScopeSet
90
emptyInScopeSet = InScope emptyVarSet (_ILIT(1))
91
92
93
94
95

getInScopeVars ::  InScopeSet -> VarEnv Var
getInScopeVars (InScope vs _) = vs

mkInScopeSet :: VarEnv Var -> InScopeSet
96
mkInScopeSet in_scope = InScope in_scope (_ILIT(1))
97
98

extendInScopeSet :: InScopeSet -> Var -> InScopeSet
99
extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# _ILIT(1))
100
101
102
103
104
105

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))

106
107
108
109
extendInScopeSetSet :: InScopeSet -> VarEnv Var -> InScopeSet
extendInScopeSetSet (InScope in_scope n) vs
   = InScope (in_scope `plusVarEnv` vs) (n +# iUnbox (sizeUFM vs))

110
111
112
113
delInScopeSet :: InScopeSet -> Var -> InScopeSet
delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n

elemInScopeSet :: Var -> InScopeSet -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
114
elemInScopeSet v (InScope in_scope _) = v `elemVarEnv` in_scope
115

116
117
-- | Look up a variable the 'InScopeSet'.  This lets you map from 
-- the variable's identity (unique) to its full value.
118
lookupInScope :: InScopeSet -> Var -> Maybe Var
119
lookupInScope (InScope in_scope _) v  = lookupVarEnv in_scope v
120
121
122
123

lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var
lookupInScope_Directly (InScope in_scope _) uniq
  = lookupVarEnv_Directly in_scope uniq
124
125
126
127

unionInScope :: InScopeSet -> InScopeSet -> InScopeSet
unionInScope (InScope s1 _) (InScope s2 n2)
  = InScope (s1 `plusVarEnv` s2) n2
128
\end{code}
129

130
\begin{code}
batterseapower's avatar
batterseapower committed
131
132
-- | @uniqAway in_scope v@ finds a unique that is not used in the
-- in-scope set, and gives that to v. 
133
uniqAway :: InScopeSet -> Var -> Var
batterseapower's avatar
batterseapower committed
134
135
136
-- It starts with v's current unique, of course, in the hope that it won't
-- have to change, and thereafter uses a combination of that and the hash-code
-- found in the in-scope set
137
138
139
140
141
142
143
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
144
  = try (_ILIT(1))
145
146
147
  where
    orig_unique = getUnique var
    try k 
148
	  | debugIsOn && (k ># _ILIT(1000))
149
	  = pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) 
150
	  | uniq `elemVarSetByKey` set = try (k +# _ILIT(1))
151
	  | debugIsOn && opt_PprStyle_Debug && (k ># _ILIT(3))
152
153
154
155
156
	  = pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) 
	    setVarUnique var uniq
	  | otherwise = setVarUnique var uniq
	  where
	    uniq = deriveUnique orig_unique (iBox (n *# k))
157
158
\end{code}

159
160
161
162
163
164
165
%************************************************************************
%*									*
		Dual renaming
%*									*
%************************************************************************

\begin{code}
batterseapower's avatar
batterseapower committed
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
-- | 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
--
-- 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:
--
-- 1. A renaming for the left-hand expression
--
-- 2. A renaming for the right-hand expressions
--
-- 3. An in-scope set
-- 
-- 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 1.
-- and 2., but we must ensure that we always extend the mappings as we go in.
--
-- All of this information is bundled up in the 'RnEnv2'
data RnEnv2
193
194
195
196
197
198
199
200
201
202
203
204
205
206
  = 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 }

207
208
209
210
211
212
213
extendRnInScopeList :: RnEnv2 -> [Var] -> RnEnv2
extendRnInScopeList env vs
  = env { in_scope = extendInScopeSetList (in_scope env) vs }

rnInScope :: Var -> RnEnv2 -> Bool
rnInScope x env = x `elemInScopeSet` in_scope env

214
215
216
rnInScopeSet :: RnEnv2 -> InScopeSet
rnInScopeSet = in_scope

217
rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2
batterseapower's avatar
batterseapower committed
218
-- ^ Applies 'rnBndr2' to several variables: the two variable lists must be of equal length
219
220
221
rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR 

rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2
batterseapower's avatar
batterseapower committed
222
223
224
225
-- ^ @rnBndr2 env bL bR@ goes under a binder @bL@ in the Left term,
-- 		         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@
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
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} }

batterseapower's avatar
batterseapower committed
244
245
rnBndrL :: RnEnv2 -> Var -> (RnEnv2, Var)
-- ^ Similar to 'rnBndr2' but used when there's a binder on the left
246
-- side only.
247
248
rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL
  = (RV2 { envL     = extendVarEnv envL bL new_b
249
         , envR     = envR
250
251
	 , in_scope = extendInScopeSet in_scope new_b }, new_b)
  where
252
    new_b = uniqAway in_scope bL
253

batterseapower's avatar
batterseapower committed
254
255
rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var)
-- ^ Similar to 'rnBndr2' but used when there's a binder on the right
256
-- side only.
257
rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR
258
259
  = (RV2 { envR     = extendVarEnv envR bR new_b
         , envL     = envL
260
261
	 , in_scope = extendInScopeSet in_scope new_b }, new_b)
  where
262
    new_b = uniqAway in_scope bR
263

264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
rnEtaL :: RnEnv2 -> Var -> (RnEnv2, Var)
-- ^ Similar to 'rnBndrL' but used for eta expansion
-- See Note [Eta expansion]
rnEtaL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL
  = (RV2 { envL     = extendVarEnv envL bL new_b
	 , envR     = extendVarEnv envR new_b new_b 	-- Note [Eta expansion]
	 , in_scope = extendInScopeSet in_scope new_b }, new_b)
  where
    new_b = uniqAway in_scope bL

rnEtaR :: RnEnv2 -> Var -> (RnEnv2, Var)
-- ^ Similar to 'rnBndr2' but used for eta expansion
-- See Note [Eta expansion]
rnEtaR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR
  = (RV2 { envL     = extendVarEnv envL new_b new_b	-- Note [Eta expansion]
	 , envR     = extendVarEnv envR bR new_b
	 , in_scope = extendInScopeSet in_scope new_b }, new_b)
  where
    new_b = uniqAway in_scope bR
283

284
rnOccL, rnOccR :: RnEnv2 -> Var -> Var
batterseapower's avatar
batterseapower committed
285
-- ^ Look up the renaming of an occurrence in the left or right term
286
287
288
289
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
batterseapower's avatar
batterseapower committed
290
-- ^ Tells whether a variable is locally bound
291
292
inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env
inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env
293

294
295
296
lookupRnInScope :: RnEnv2 -> Var -> Var
lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v

297
nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2
batterseapower's avatar
batterseapower committed
298
-- ^ Wipe the left or right side renaming
299
300
301
302
nukeRnEnvL env = env { envL = emptyVarEnv }
nukeRnEnvR env = env { envR = emptyVarEnv }
\end{code}

303
304
305
306
307
308
309
310
311
312
313
314
315
316
Note [Eta expansion]
~~~~~~~~~~~~~~~~~~~~
When matching
     (\x.M) ~ N
we rename x to x' with, where x' is not in scope in 
either term.  Then we want to behave as if we'd seen
     (\x'.M) ~ (\x'.N x')
Since x' isn't in scope in N, the form (\x'. N x') doesn't
capture any variables in N.  But we must nevertheless extend
the envR with a binding [x' -> x'], to support the occurs check.
For example, if we don't do this, we can get silly matches like
	forall a.  (\y.a)  ~   v
succeeding with [a -> v y], which is bogus of course.

317

318
319
%************************************************************************
%*									*
320
		Tidying
321
322
323
%*									*
%************************************************************************

324
\begin{code}
batterseapower's avatar
batterseapower committed
325
326
-- | 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
327
type TidyEnv = (TidyOccEnv, VarEnv Var)
328

329
330
emptyTidyEnv :: TidyEnv
emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv)
331
332
333
\end{code}


334
335
336
337
338
339
340
341
342
343
344
345
%************************************************************************
%*									*
\subsection{@VarEnv@s}
%*									*
%************************************************************************

\begin{code}
type VarEnv elt   = UniqFM elt
type IdEnv elt    = VarEnv elt
type TyVarEnv elt = VarEnv elt

emptyVarEnv	  :: VarEnv a
346
347
348
349
mkVarEnv	  :: [(Var, a)] -> VarEnv a
zipVarEnv	  :: [Var] -> [a] -> VarEnv a
unitVarEnv	  :: Var -> a -> VarEnv a
extendVarEnv	  :: VarEnv a -> Var -> a -> VarEnv a
350
extendVarEnv_C	  :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a
351
extendVarEnv_Acc  :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b
352
plusVarEnv	  :: VarEnv a -> VarEnv a -> VarEnv a
353
extendVarEnvList  :: VarEnv a -> [(Var, a)] -> VarEnv a
354
		  
355
356
lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a
filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a
357
restrictVarEnv    :: VarEnv a -> VarSet -> VarEnv a
358
359
delVarEnvList     :: VarEnv a -> [Var] -> VarEnv a
delVarEnv	  :: VarEnv a -> Var -> VarEnv a
360
361
minusVarEnv       :: VarEnv a -> VarEnv a -> VarEnv a
intersectsVarEnv  :: VarEnv a -> VarEnv a -> Bool
362
363
plusVarEnv_C	  :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
mapVarEnv	  :: (a -> b) -> VarEnv a -> VarEnv b
364
modifyVarEnv	  :: (a -> a) -> VarEnv a -> Var -> VarEnv a
365
varEnvElts	  :: VarEnv a -> [a]
366
varEnvKeys	  :: VarEnv a -> [Unique]
367
368
		  
isEmptyVarEnv	  :: VarEnv a -> Bool
369
370
lookupVarEnv	  :: VarEnv a -> Var -> Maybe a
lookupVarEnv_NF   :: VarEnv a -> Var -> a
371
lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a
372
elemVarEnv	  :: Var -> VarEnv a -> Bool
373
elemVarEnvByKey   :: Unique -> VarEnv a -> Bool
374
375
376
377
378
foldVarEnv	  :: (a -> b -> b) -> b -> VarEnv a -> b
\end{code}

\begin{code}
elemVarEnv       = elemUFM
379
elemVarEnvByKey  = elemUFM_Directly
380
extendVarEnv	 = addToUFM
381
extendVarEnv_C	 = addToUFM_C
382
extendVarEnv_Acc = addToUFM_Acc
383
extendVarEnvList = addListToUFM
384
385
386
plusVarEnv_C	 = plusUFM_C
delVarEnvList	 = delListFromUFM
delVarEnv	 = delFromUFM
387
388
minusVarEnv      = minusUFM
intersectsVarEnv e1 e2 = not (isEmptyVarEnv (e1 `intersectUFM` e2))
389
390
plusVarEnv	 = plusUFM
lookupVarEnv	 = lookupUFM
391
lookupWithDefaultVarEnv = lookupWithDefaultUFM
392
393
394
mapVarEnv	 = mapUFM
mkVarEnv	 = listToUFM
emptyVarEnv	 = emptyUFM
395
varEnvElts	 = eltsUFM
396
varEnvKeys	 = keysUFM
397
398
399
unitVarEnv	 = unitUFM
isEmptyVarEnv	 = isNullUFM
foldVarEnv	 = foldUFM
400
401
lookupVarEnv_Directly = lookupUFM_Directly
filterVarEnv_Directly = filterUFM_Directly
402

403
404
405
406
restrictVarEnv env vs = filterVarEnv_Directly keep env
  where
    keep u _ = u `elemVarSetByKey` vs
    
407
zipVarEnv tyvars tys   = mkVarEnv (zipEqual "zipVarEnv" tyvars tys)
Ian Lynagh's avatar
Ian Lynagh committed
408
409
410
lookupVarEnv_NF env id = case lookupVarEnv env id of
                         Just xx -> xx
                         Nothing -> panic "lookupVarEnv_NF: Nothing"
411
412
413
414
415
416
417
418
419
420
421
\end{code}

@modifyVarEnv@: Look up a thing in the VarEnv, 
then mash it with the modify function, and put it back.

\begin{code}
modifyVarEnv mangle_fn env key
  = case (lookupVarEnv env key) of
      Nothing -> env
      Just xx -> extendVarEnv env key (mangle_fn xx)

Ian Lynagh's avatar
Ian Lynagh committed
422
modifyVarEnv_Directly :: (a -> a) -> UniqFM a -> Unique -> UniqFM a
423
424
425
426
427
modifyVarEnv_Directly mangle_fn env key
  = case (lookupUFM_Directly env key) of
      Nothing -> env
      Just xx -> addToUFM_Directly env key (mangle_fn xx)
\end{code}