From bc86223d8822da6949334ddb8b9040cf65637b4a Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Fri, 20 Mar 1998 21:17:46 +0000
Subject: [PATCH] [project @ 1998-03-20 21:17:43 by simonpj] Substitution bug
 in simplifier fixed

---
 ghc/compiler/simplCore/SimplVar.lhs |   17 ++++++++++++-----
 ghc/compiler/types/TyVar.lhs        |    6 ++++--
 ghc/compiler/utils/UniqSet.lhs      |    5 ++++-
 3 files changed, 20 insertions(+), 8 deletions(-)

diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs
index 92cd7cf..5daf73e 100644
--- a/ghc/compiler/simplCore/SimplVar.lhs
+++ b/ghc/compiler/simplCore/SimplVar.lhs
@@ -201,9 +201,13 @@ simplBinder env (id, occ_info)
            | otherwise               = setIdSpecialisation id spec_env'
     in
     if not_in_scope then
-	-- No need to clone
+	-- No need to clone, but we *must* zap any current substitution
+	-- for the variable.  For example:
+	--	(\x.e) with id_subst = [x |-> e']
+	-- Here we must simply zap the substitution for x
 	let
-	    env' = setIdEnv env (new_in_scope_ids id2, id_subst)
+	    env' = setIdEnv env (new_in_scope_ids id2, 
+				 delOneFromIdEnv id_subst id)
 	in
 	returnSmpl (env', id2)
     else
@@ -237,9 +241,12 @@ simplBinders env binders = mapAccumLSmpl simplBinder env binders
 \begin{code}	
 simplTyBinder :: SimplEnv -> TyVar -> SmplM (SimplEnv, TyVar)
 simplTyBinder env tyvar
-  | not (tyvar `elementOfTyVarSet` tyvars)	-- No need to clone
-  = let
-	env' = setTyEnv env (tyvars `addOneToTyVarSet` tyvar, ty_subst)
+  | not (tyvar `elementOfTyVarSet` tyvars)
+  = 	-- No need to clone; but must zap any binding for tyvar
+	-- see comments with simplBinder above
+    let
+	env' = setTyEnv env (tyvars `addOneToTyVarSet` tyvar, 
+			     delFromTyVarEnv ty_subst tyvar)
     in
     returnSmpl (env', tyvar)
 
diff --git a/ghc/compiler/types/TyVar.lhs b/ghc/compiler/types/TyVar.lhs
index c106981..aa32001 100644
--- a/ghc/compiler/types/TyVar.lhs
+++ b/ghc/compiler/types/TyVar.lhs
@@ -21,7 +21,7 @@ module TyVar (
 	emptyTyVarSet, unitTyVarSet, unionTyVarSets, addOneToTyVarSet,
 	unionManyTyVarSets, intersectTyVarSets, mkTyVarSet,
 	tyVarSetToList, elementOfTyVarSet, minusTyVarSet,
-	isEmptyTyVarSet
+	isEmptyTyVarSet, delOneFromTyVarSet
   ) where
 
 #include "HsVersions.h"
@@ -31,7 +31,7 @@ import Kind		( Kind, mkBoxedTypeKind, mkTypeKind )
 
 -- others
 import UniqSet		-- nearly all of it
-import UniqFM		( emptyUFM, listToUFM, addToUFM, lookupUFM,
+import UniqFM		( emptyUFM, listToUFM, addToUFM, lookupUFM, delFromUFM,
 			  plusUFM, sizeUFM, delFromUFM, isNullUFM, UniqFM
 			)
 import BasicTypes	( Unused, unused )
@@ -149,10 +149,12 @@ minusTyVarSet	  :: GenTyVarSet flexi -> GenTyVarSet flexi -> GenTyVarSet flexi
 isEmptyTyVarSet   :: GenTyVarSet flexi -> Bool
 mkTyVarSet	  :: [GenTyVar flexi] -> GenTyVarSet flexi
 addOneToTyVarSet  :: GenTyVarSet flexi -> GenTyVar flexi -> GenTyVarSet flexi
+delOneFromTyVarSet :: GenTyVarSet flexi -> GenTyVar flexi -> GenTyVarSet flexi
 
 emptyTyVarSet  	  = emptyUniqSet
 unitTyVarSet      = unitUniqSet
 addOneToTyVarSet  = addOneToUniqSet
+delOneFromTyVarSet = delOneFromUniqSet
 intersectTyVarSets= intersectUniqSets
 unionTyVarSets 	  = unionUniqSets
 unionManyTyVarSets= unionManyUniqSets
diff --git a/ghc/compiler/utils/UniqSet.lhs b/ghc/compiler/utils/UniqSet.lhs
index 5089694..6412cc0 100644
--- a/ghc/compiler/utils/UniqSet.lhs
+++ b/ghc/compiler/utils/UniqSet.lhs
@@ -12,7 +12,7 @@ module UniqSet (
 	UniqSet,    -- abstract type: NOT
 
 	mkUniqSet, uniqSetToList, emptyUniqSet, unitUniqSet,
-	addOneToUniqSet, addListToUniqSet,
+	addOneToUniqSet, addListToUniqSet, delOneFromUniqSet,
 	unionUniqSets, unionManyUniqSets, minusUniqSet,
 	elementOfUniqSet, mapUniqSet, intersectUniqSets,
 	isEmptyUniqSet, filterUniqSet, sizeUniqSet
@@ -63,6 +63,9 @@ mkUniqSet xs = MkUniqSet (listToUFM [ (x, x) | x <- xs])
 addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a
 addOneToUniqSet (MkUniqSet set) x = MkUniqSet (addToUFM set x x)
 
+delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a
+delOneFromUniqSet (MkUniqSet set) x = MkUniqSet (delFromUFM set x)
+
 addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a
 addListToUniqSet (MkUniqSet set) xs = MkUniqSet (addListToUFM set [(x,x) | x<-xs])
 
-- 
1.7.10.4