From 794c2f4c8829ba3166c9bdb471856bc00c21f001 Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Fri, 30 Oct 2009 17:56:52 +0000
Subject: [PATCH] Cure an assert failure by gathering the right set of free
 variables

---
 compiler/coreSyn/CoreSubst.lhs  |    8 ++++----
 compiler/coreSyn/CoreUnfold.lhs |    8 +++++++-
 2 files changed, 11 insertions(+), 5 deletions(-)

diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs
index f1f02d9..3fe4800 100644
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/compiler/coreSyn/CoreSubst.lhs
@@ -227,10 +227,10 @@ lookupTvSubst (Subst _ _ tvs) v = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v
 --   No left-right shadowing
 --   ie the substitution for   (\x \y. e) a1 a2
 --      so neither x nor y scope over a1 a2
-mkOpenSubst :: [(Var,CoreArg)] -> Subst
-mkOpenSubst pairs = Subst (mkInScopeSet (exprsFreeVars (map snd pairs)))
-	    	          (mkVarEnv [(id,e)  | (id, e) <- pairs, isId id])
-			  (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs])
+mkOpenSubst :: InScopeSet -> [(Var,CoreArg)] -> Subst
+mkOpenSubst in_scope pairs = Subst in_scope
+	    	          	   (mkVarEnv [(id,e)  | (id, e) <- pairs, isId id])
+			  	   (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs])
 
 ------------------------------
 isInScope :: Var -> Subst -> Bool
diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index f32d5b1..ae46a8b 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -42,6 +42,7 @@ import CoreSyn
 import PprCore		()	-- Instances
 import OccurAnal
 import CoreSubst hiding( substTy )
+import CoreFVs         ( exprFreeVars )
 import CoreUtils
 import Id
 import DataCon
@@ -54,6 +55,7 @@ import TcType		( tcSplitDFunTy )
 import Type 
 import Coercion
 import PrelNames
+import VarEnv           ( mkInScopeSet )
 import Bag
 import Util
 import FastTypes
@@ -1110,6 +1112,9 @@ exprIsConApp_maybe expr
     analyse _ _ = Nothing
 
     -----------
+    in_scope = mkInScopeSet (exprFreeVars expr)
+
+    -----------
     beta (Lam v body) pairs (arg : args) 
         | isTypeArg arg
         = beta body ((v,arg):pairs) args 
@@ -1118,12 +1123,13 @@ exprIsConApp_maybe expr
 	= Nothing
 
     beta fun pairs args
-        = case analyse (substExpr (mkOpenSubst pairs) fun) args of
+        = case analyse (substExpr subst fun) args of
 	    Nothing  -> -- pprTrace "Bale out! exprIsConApp_maybe" doc $
 	    	        Nothing
 	    Just ans -> -- pprTrace "Woo-hoo! exprIsConApp_maybe" doc $
                         Just ans
         where
+          subst = mkOpenSubst in_scope pairs
 	  -- doc = vcat [ppr fun, ppr expr, ppr pairs, ppr args]
 
 
-- 
1.7.10.4