X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FVarEnv.lhs;h=d65ec5face4dddd9d2cdcc630cbe9e69a51a2203;hb=14ec5696ff3bafc1ec0f2277f0b2e4ce6c59e462;hp=bfeecdc923d41925ff3e2d69d12a03f558339913;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs
index bfeecdc..d65ec5f 100644
--- a/compiler/basicTypes/VarEnv.lhs
+++ b/compiler/basicTypes/VarEnv.lhs
@@ -1,9 +1,16 @@
-
+%
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-\section{@VarEnvs@: Variable environments}
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module VarEnv (
 	VarEnv, IdEnv, TyVarEnv,
 	emptyVarEnv, unitVarEnv, mkVarEnv,
@@ -20,13 +27,15 @@ 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,
+		rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, extendRnInScopeList,
+		rnInScope, rnInScopeSet, lookupRnInScope,
 
 	-- TidyEnvs
 	TidyEnv, emptyTidyEnv
@@ -34,14 +43,14 @@ 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, isJust )
-import StaticFlags( opt_PprStyle_Debug )
+import Unique
+import Util
+import Maybes
+import StaticFlags
 import Outputable
 import FastTypes
 \end{code}
@@ -63,26 +72,30 @@ instance Outputable InScopeSet where
   ppr (InScope s i) = 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
@@ -121,17 +134,17 @@ 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#
+	  | k ># _ILIT(1000)
 	  = pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) 
 #endif			    
-	  | uniq `elemVarSetByKey` set = try (k +# 1#)
+	  | uniq `elemVarSetByKey` set = try (k +# _ILIT(1))
 #ifdef DEBUG
-	  | opt_PprStyle_Debug && k ># 3#
+	  | opt_PprStyle_Debug && k ># _ILIT(3)
 	  = pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) 
 	    setVarUnique var uniq
 #endif			    
@@ -183,6 +196,16 @@ mkRnEnv2 vars = RV2	{ envL 	   = emptyVarEnv
 			, envR 	   = emptyVarEnv
 			, in_scope = vars }
 
+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
+
+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 
@@ -213,21 +236,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
@@ -236,8 +271,11 @@ rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v
 
 inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool
 -- Tells whether a variable is locally bound
-inRnEnvL (RV2 { envL = env }) v = isJust (lookupVarEnv env v)
-inRnEnvR (RV2 { envR = env }) v = isJust (lookupVarEnv env v)
+inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env
+inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env
+
+lookupRnInScope :: RnEnv2 -> Var -> Var
+lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v
 
 nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2
 nukeRnEnvL env = env { envL = emptyVarEnv }