X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreFVs.lhs;h=e2eb3a2e82b2d4de9540870b0743d30a4418ffb0;hb=69f8ed93800605d8df011388450d6d3bb9ca6071;hp=dedc4c06d337885bdec3fb16efbc96b36d9adc50;hpb=08409937537b9d4d8937e1d7264f6b238d350ccd;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs
index dedc4c0..e2eb3a2 100644
--- a/compiler/coreSyn/CoreFVs.lhs
+++ b/compiler/coreSyn/CoreFVs.lhs
@@ -25,7 +25,7 @@ module CoreFVs (
 	exprFreeNames, exprsFreeNames,
 
         -- * Free variables of Rules, Vars and Ids
-	idRuleVars, idFreeVars, varTypeTyVars, 
+	idRuleVars, idFreeVars, varTypeTyVars, varTypeTcTyVars, 
 	ruleRhsFreeVars, rulesFreeVars,
 	ruleLhsFreeNames, ruleLhsFreeIds, 
 
@@ -194,7 +194,7 @@ expr_fvs (Let (Rec pairs) body)
 
 ---------
 rhs_fvs :: (Id,CoreExpr) -> FV
-rhs_fvs (bndr, rhs) = expr_fvs rhs `union` someVars (idRuleVars bndr)
+rhs_fvs (bndr, rhs) = expr_fvs rhs `union` someVars (bndrRuleVars bndr)
 	-- Treat any RULES as extra RHSs of the binding
 
 ---------
@@ -370,9 +370,20 @@ varTypeTyVars var
   | isLocalId var || isCoVar var = tyVarsOfType (idType var)
   | otherwise = emptyVarSet	-- Global Ids and non-coercion TyVars
 
+varTypeTcTyVars :: Var -> TyVarSet
+-- Find the type variables free in the type of the variable
+-- Remember, coercion variables can mention type variables...
+varTypeTcTyVars var
+  | isLocalId var || isCoVar var = tcTyVarsOfType (idType var)
+  | otherwise = emptyVarSet	-- Global Ids and non-coercion TyVars
+
 idFreeVars :: Id -> VarSet
 idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` varTypeTyVars id
 
+bndrRuleVars ::Var -> VarSet
+bndrRuleVars v | isTyVar v = emptyVarSet
+	       | otherwise = idRuleVars v
+
 idRuleVars ::Id -> VarSet
 idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
 \end{code}
@@ -425,7 +436,7 @@ freeVars (Case scrut bndr ty alts)
 			     rhs2 = freeVars rhs
 
 freeVars (Let (NonRec binder rhs) body)
-  = (freeVarsOf rhs2 `unionFVs` body_fvs `unionFVs` idRuleVars binder,
+  = (freeVarsOf rhs2 `unionFVs` body_fvs `unionFVs` bndrRuleVars binder,
 		-- Remember any rules; cf rhs_fvs above
      AnnLet (AnnNonRec binder rhs2) body2)
   where