X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreFVs.lhs;h=f54b268234ba85c34a5d6eb2c3273429a5ada210;hb=6c3c61e070a52231887db1cdc3a35bec021dcf42;hp=3c4d5c87c9c4296b5119032ffcecf60dd2251cf7;hpb=111cee3f1ad93816cb828e38b38521d85c3bcebb;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs
index 3c4d5c8..f54b268 100644
--- a/ghc/compiler/coreSyn/CoreFVs.lhs
+++ b/ghc/compiler/coreSyn/CoreFVs.lhs
@@ -5,24 +5,34 @@ Taken quite directly from the Peyton Jones/Lester paper.
 
 \begin{code}
 module CoreFVs (
-	exprFreeVars, exprsFreeVars,
+	exprFreeVars,	-- CoreExpr -> VarSet	-- Find all locally-defined free Ids or tyvars
+	exprsFreeVars,	-- [CoreExpr] -> VarSet
+
 	exprSomeFreeVars, exprsSomeFreeVars,
-	idRuleVars, idFreeVars, ruleSomeFreeVars, ruleSomeLhsFreeVars,
 
-	CoreExprWithFVs, CoreBindWithFVs, freeVars, freeVarsOf,
+	idRuleVars, idFreeVars, idFreeTyVars,
+	ruleRhsFreeVars, ruleLhsFreeNames, ruleLhsFreeIds, 
+
+	CoreExprWithFVs,	-- = AnnExpr Id VarSet
+	CoreBindWithFVs,	-- = AnnBind Id VarSet
+	freeVars,		-- CoreExpr -> CoreExprWithFVs
+	freeVarsOf		-- CoreExprWithFVs -> IdSet
     ) where
 
 #include "HsVersions.h"
 
 import CoreSyn
-import Id		( Id, idFreeTyVars, idSpecialisation )
+import Id		( Id, idType, idSpecialisation )
+import NameSet
 import VarSet
-import Var		( Var, isId )
-import Name		( isLocallyDefined )
-import Type		( tyVarsOfType, Type )
+import Var		( Var, isId, isLocalVar, varName )
+import Type		( tyVarsOfType )
+import TcType		( tyClsNamesOfType )
 import Util		( mapAndUnzip )
+import Outputable
 \end{code}
 
+
 %************************************************************************
 %*									*
 \section{Finding the free variables of an expression}
@@ -39,7 +49,7 @@ but not those that are free in the type of variable occurrence.
 
 \begin{code}
 exprFreeVars :: CoreExpr -> VarSet	-- Find all locally-defined free Ids or tyvars
-exprFreeVars = exprSomeFreeVars isLocallyDefined
+exprFreeVars = exprSomeFreeVars isLocalVar
 
 exprsFreeVars :: [CoreExpr] -> VarSet
 exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet
@@ -75,9 +85,10 @@ noVars fv_cand in_scope = emptyVarSet
 -- is a little weird.  The reason is that the former is more efficient,
 -- but the latter is more fine grained, and a makes a difference when
 -- a variable mentions itself one of its own rule RHSs
-oneVar :: Var -> FV
+oneVar :: Id -> FV
 oneVar var fv_cand in_scope
-  = foldVarSet add_rule_var var_itself_set (idRuleVars var)
+  = ASSERT( isId var ) 
+    foldVarSet add_rule_var var_itself_set (idRuleVars var)
   where
     var_itself_set | keep_it fv_cand in_scope var = unitVarSet var
 	           | otherwise		      = emptyVarSet
@@ -116,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)
 
@@ -131,30 +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}
-idRuleVars ::Id -> VarSet
-idRuleVars id = rulesRhsFreeVars (idSpecialisation id)
+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}
 
-idFreeVars :: Id -> VarSet
-idFreeVars id = idRuleVars id `unionVarSet` idFreeTyVars id
+%************************************************************************
+%*									*
+\section[freevars-everywhere]{Attaching free variables to every sub-expression}
+%*									*
+%************************************************************************
 
-rulesSomeFreeVars :: InterestingVarFun -> CoreRules -> VarSet
-rulesSomeFreeVars interesting (Rules rules _)
-  = foldr (unionVarSet . ruleSomeFreeVars interesting) emptyVarSet rules
 
-ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> VarSet
-ruleSomeFreeVars interesting (BuiltinRule _) = noFVs
-ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs)
-  = rule_fvs interesting emptyVarSet
+\begin{code}
+ruleRhsFreeVars :: CoreRule -> VarSet
+ruleRhsFreeVars (BuiltinRule _ _) = noFVs
+ruleRhsFreeVars (Rule str _ tpl_vars tpl_args rhs)
+  = rule_fvs isLocalVar emptyVarSet
   where
-    rule_fvs = addBndrs tpl_vars $
-	       foldr (union . expr_fvs) (expr_fvs rhs) tpl_args
+    rule_fvs = addBndrs tpl_vars (expr_fvs rhs)
 
-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}
 
 
@@ -180,9 +240,13 @@ noFVs    = emptyVarSet
 aFreeVar = unitVarSet
 unionFVs = unionVarSet
 
-filters :: Var -> VarSet -> VarSet
+delBindersFV :: [Var] -> VarSet -> VarSet
+delBindersFV bs fvs = foldr delBinderFV fvs bs
+
+delBinderFV :: Var -> VarSet -> VarSet
+-- This way round, so we can do it multiple times using foldr
 
--- (b `filters` s) removes the binder b from the free variable set s,
+-- (b `delBinderFV` s) removes the binder b from the free variable set s,
 -- but *adds* to s
 --	(a) the free variables of b's type
 --	(b) the idSpecVars of b
@@ -210,8 +274,21 @@ filters :: Var -> VarSet -> VarSet
 --			  where
 --			    bottom = bottom -- Never evaluated
 
-filters b s | isId b    = (s `delVarSet` b) `unionFVs` idFreeVars b
-	    | otherwise = s `delVarSet` b
+delBinderFV b s | isId b    = (s `delVarSet` b) `unionFVs` idFreeVars b
+	        | otherwise = s `delVarSet` b
+
+idFreeVars :: Id -> VarSet
+idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id
+
+idFreeTyVars :: Id -> TyVarSet
+-- Only local Ids conjured up locally, can have free type variables.
+-- (During type checking top-level Ids can have free tyvars)
+idFreeTyVars id = tyVarsOfType (idType id)
+-- | isLocalId id = tyVarsOfType (idType id)
+-- | otherwise    = emptyVarSet
+
+idRuleVars ::Id -> VarSet
+idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id)
 \end{code}
 
 
@@ -232,12 +309,12 @@ freeVars (Var v)
 	--	Actually [June 98] I don't think it's necessary
 	-- fvs = fvs_v `unionVarSet` idSpecVars v
 
-    fvs | isLocallyDefined v = aFreeVar v
-	| otherwise	     = noFVs
+    fvs | isLocalVar v = aFreeVar v
+	| otherwise    = noFVs
 
 freeVars (Lit lit) = (noFVs, AnnLit lit)
 freeVars (Lam b body)
-  = (b `filters` freeVarsOf body', AnnLam b body')
+  = (b `delBinderFV` freeVarsOf body', AnnLam b body')
   where
     body' = freeVars body
 
@@ -247,16 +324,17 @@ freeVars (App fun arg)
     fun2 = freeVars fun
     arg2 = freeVars arg
 
-freeVars (Case scrut bndr alts)
-  = ((bndr `filters` 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
 
     (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
     alts_fvs 		= foldr1 unionFVs alts_fvs_s
 
-    fv_alt (con,args,rhs) = (foldr filters (freeVarsOf rhs2) args,
+    fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
 			     (con, args, rhs2))
 		    	  where
 			     rhs2 = freeVars rhs
@@ -267,11 +345,11 @@ freeVars (Let (NonRec binder rhs) body)
   where
     rhs2     = freeVars rhs
     body2    = freeVars body
-    body_fvs = binder `filters` freeVarsOf body2
+    body_fvs = binder `delBinderFV` freeVarsOf body2
 
 freeVars (Let (Rec binds) body)
   = (foldl delVarSet group_fvs binders,
-	-- The "filters" part may have added one of the binders
+	-- The "delBinderFV" part may have added one of the binders
 	-- via the idSpecVars part, so we must delete it again
      AnnLet (AnnRec (binders `zip` rhss2)) body2)
   where
@@ -279,7 +357,7 @@ freeVars (Let (Rec binds) body)
 
     rhss2     = map freeVars rhss
     all_fvs   = foldr (unionFVs . fst) body_fvs rhss2
-    group_fvs = foldr filters all_fvs binders
+    group_fvs = delBindersFV binders all_fvs
 
     body2     = freeVars body
     body_fvs  = freeVarsOf body2