[project @ 2005-02-28 16:02:57 by simonpj]

[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreFVs.lhs

diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs
index 4729b20..f54b268 100644 (file)
--- a/ghc/compiler/coreSyn/CoreFVs.lhs
+++ b/ghc/compiler/coreSyn/CoreFVs.lhs
@@ -11,7 +11,7 @@ module CoreFVs (
        exprSomeFreeVars, exprsSomeFreeVars,
 
        idRuleVars, idFreeVars, idFreeTyVars,
-       ruleSomeFreeVars, ruleSomeLhsFreeVars, ruleRhsFreeVars,
+       ruleRhsFreeVars, ruleLhsFreeNames, ruleLhsFreeIds, 
 
        CoreExprWithFVs,        -- = AnnExpr Id VarSet
        CoreBindWithFVs,        -- = AnnBind Id VarSet
@@ -22,10 +22,12 @@ module CoreFVs (
 #include "HsVersions.h"
 
 import CoreSyn
-import Id              ( Id, idType, isLocalId, hasNoBinding, idSpecialisation )
+import Id              ( Id, idType, idSpecialisation )
+import NameSet
 import VarSet
-import Var             ( Var, isId, isLocalVar )
+import Var             ( Var, isId, isLocalVar, varName )
 import Type            ( tyVarsOfType )
+import TcType          ( tyClsNamesOfType )
 import Util            ( mapAndUnzip )
 import Outputable
 \end{code}
@@ -125,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)
 
@@ -140,31 +144,77 @@ expr_fvs (Let (Rec pairs) body)
 \end{code}
 
 
+%************************************************************************
+%*                                                                     *
+\section{Free names}
+%*                                                                     *
+%************************************************************************
+
+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 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
+make the whole module an orphan module, which is bad.
 
 \begin{code}
-rulesSomeFreeVars :: InterestingVarFun -> CoreRules -> VarSet
-rulesSomeFreeVars interesting (Rules rules _)
-  = foldr (unionVarSet . ruleSomeFreeVars interesting) emptyVarSet rules
+ruleLhsFreeNames :: IdCoreRule -> NameSet
+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)   = 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
+
+exprFreeNames (Let (NonRec b r) e) = (exprFreeNames e `delFromNameSet` varName b)
+                                    `unionNameSets` exprFreeNames r
+
+exprFreeNames (Let (Rec prs) e) = (exprsFreeNames rs `unionNameSets` exprFreeNames e)
+                                 `del_binders` bs
+                               where
+                                 (bs, rs) = unzip prs
+
+-- 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
+
+exprsFreeNames es = foldr (unionNameSets . exprFreeNames) emptyNameSet es
+
+del_binders :: NameSet -> [Var] -> NameSet
+del_binders names bndrs = foldl (\s b -> delFromNameSet s (varName b)) names bndrs
+\end{code}
+
+%************************************************************************
+%*                                                                     *
+\section[freevars-everywhere]{Attaching free variables to every sub-expression}
+%*                                                                     *
+%************************************************************************
 
+
+\begin{code}
 ruleRhsFreeVars :: CoreRule -> VarSet
-ruleRhsFreeVars (BuiltinRule _) = noFVs
-ruleRhsFreeVars (Rule str tpl_vars tpl_args rhs)
+ruleRhsFreeVars (BuiltinRule _ _) = noFVs
+ruleRhsFreeVars (Rule str _ tpl_vars tpl_args rhs)
   = rule_fvs isLocalVar emptyVarSet
   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
-
-ruleSomeLhsFreeVars :: InterestingVarFun -> CoreRule -> VarSet
-ruleSomeLhsFreeVars fn (BuiltinRule _) = noFVs
-ruleSomeLhsFreeVars fn (Rule _ tpl_vars tpl_args rhs)
-  = foldl delVarSet (exprsSomeFreeVars fn tpl_args) tpl_vars
+ruleLhsFreeIds :: CoreRule -> VarSet
+-- 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 (exprsFreeVars tpl_args) tpl_vars
 \end{code}
 
 
@@ -274,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