X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreFVs.lhs;h=f54b268234ba85c34a5d6eb2c3273429a5ada210;hb=a84285247bfb162fdefc3fcb8be88c34c1f5cd35;hp=0bce99ba2583bbc2ca4e6d214a92b5a25e6e1b83;hpb=e0d750bedbd33f7a133c8c82c35fd8db537ab649;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs
index 0bce99b..f54b268 100644
--- a/ghc/compiler/coreSyn/CoreFVs.lhs
+++ b/ghc/compiler/coreSyn/CoreFVs.lhs
@@ -11,8 +11,7 @@ module CoreFVs (
 	exprSomeFreeVars, exprsSomeFreeVars,
 
 	idRuleVars, idFreeVars, idFreeTyVars,
-	ruleSomeFreeVars, ruleRhsFreeVars,
-	ruleLhsFreeNames, ruleLhsFreeIds, 
+	ruleRhsFreeVars, ruleLhsFreeNames, ruleLhsFreeIds, 
 
 	CoreExprWithFVs,	-- = AnnExpr Id VarSet
 	CoreBindWithFVs,	-- = AnnBind Id VarSet
@@ -28,7 +27,7 @@ import NameSet
 import VarSet
 import Var		( Var, isId, isLocalVar, varName )
 import Type		( tyVarsOfType )
-import TcType		( namesOfType )
+import TcType		( tyClsNamesOfType )
 import Util		( mapAndUnzip )
 import Outputable
 \end{code}
@@ -128,8 +127,10 @@ expr_fvs (Note _ expr)   = expr_fvs expr
 expr_fvs (App fun arg)   = expr_fvs fun `union` expr_fvs arg
 expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
 
-expr_fvs (Case scrut bndr alts)
-  = expr_fvs scrut `union` addBndr bndr (foldr (union . alt_fvs) noVars alts)
+-- gaw 2004
+expr_fvs (Case scrut bndr ty alts)
+  = expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr  
+      (foldr (union . alt_fvs) noVars alts)
   where
     alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
 
@@ -152,7 +153,7 @@ expr_fvs (Let (Rec pairs) body)
 exprFreeNames finds the free *names* of an expression, notably
 including the names of type constructors (which of course do not show
 up in exprFreeVars).  Similarly ruleLhsFreeNames.  The latter is used
-when deciding whethera rule is an orphan.  In particular, suppose that
+when deciding whether a rule is an orphan.  In particular, suppose that
 T is defined in this module; we want to avoid declaring that a rule like
 	fromIntegral T = fromIntegral_T
 is an orphan.  Of course it isn't, an declaring it an orphan would
@@ -160,14 +161,14 @@ make the whole module an orphan module, which is bad.
 
 \begin{code}
 ruleLhsFreeNames :: IdCoreRule -> NameSet
-ruleLhsFreeNames (fn, BuiltinRule _ _) = unitNameSet (varName fn)
-ruleLhsFreeNames (fn, Rule _ _ tpl_vars tpl_args rhs)
+ruleLhsFreeNames (IdCoreRule fn _ (BuiltinRule _ _)) = unitNameSet (varName fn)
+ruleLhsFreeNames (IdCoreRule fn _ (Rule _ _ tpl_vars tpl_args rhs))
   = addOneToNameSet (exprsFreeNames tpl_args `del_binders` tpl_vars) (varName fn)
 
 exprFreeNames :: CoreExpr -> NameSet
-exprFreeNames (Var v) 	= unitNameSet (varName v)
-exprFreeNames (Lit _) 	= emptyNameSet
-exprFreeNames (Type ty) = namesOfType ty
+exprFreeNames (Var v) 	  = unitNameSet (varName v)
+exprFreeNames (Lit _) 	  = emptyNameSet
+exprFreeNames (Type ty)   = tyClsNamesOfType ty	-- Don't need free tyvars
 exprFreeNames (App e1 e2) = exprFreeNames e1 `unionNameSets` exprFreeNames e2
 exprFreeNames (Lam v e)   = exprFreeNames e `delFromNameSet` varName v
 exprFreeNames (Note n e)  = exprFreeNames e
@@ -180,8 +181,10 @@ exprFreeNames (Let (Rec prs) e) = (exprsFreeNames rs `unionNameSets` exprFreeNam
 				where
 				  (bs, rs) = unzip prs
 
-exprFreeNames (Case e b as) = exprFreeNames e `unionNameSets` 
-			      (unionManyNameSets (map altFreeNames as) `delFromNameSet` varName b)
+-- gaw 2004
+exprFreeNames (Case e b ty as) = exprFreeNames e `unionNameSets` tyClsNamesOfType ty 
+                                 `unionNameSets`
+			         (unionManyNameSets (map altFreeNames as) `delFromNameSet` varName b)
 
 -- Helpers
 altFreeNames (_,bs,r) = exprFreeNames r `del_binders` bs
@@ -207,20 +210,11 @@ ruleRhsFreeVars (Rule str _ tpl_vars tpl_args rhs)
   where
     rule_fvs = addBndrs tpl_vars (expr_fvs rhs)
 
-ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> VarSet
-ruleSomeFreeVars interesting (BuiltinRule _ _) = noFVs
-ruleSomeFreeVars interesting (Rule _ _ tpl_vars tpl_args rhs)
-  = rule_fvs interesting emptyVarSet
-  where
-    rule_fvs = addBndrs tpl_vars $
-	       foldr (union . expr_fvs) (expr_fvs rhs) tpl_args
-
 ruleLhsFreeIds :: CoreRule -> VarSet
--- This finds all the free Ids on the LHS of the rule
--- *including* imported ids
+-- This finds all locally-defined free Ids on the LHS of the rule
 ruleLhsFreeIds (BuiltinRule _ _) = noFVs
 ruleLhsFreeIds (Rule _ _ tpl_vars tpl_args rhs)
-  = foldl delVarSet (exprsSomeFreeVars isId tpl_args) tpl_vars
+  = foldl delVarSet (exprsFreeVars tpl_args) tpl_vars
 \end{code}
 
 
@@ -330,9 +324,10 @@ freeVars (App fun arg)
     fun2 = freeVars fun
     arg2 = freeVars arg
 
-freeVars (Case scrut bndr alts)
-  = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2,
-     AnnCase scrut2 bndr alts2)
+freeVars (Case scrut bndr ty alts)
+-- gaw 2004
+  = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` tyVarsOfType ty,
+     AnnCase scrut2 bndr ty alts2)
   where
     scrut2 = freeVars scrut