Fix free-variable finder

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

diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs
index 6aed662..fb6017e 100644 (file)
--- a/ghc/compiler/coreSyn/CoreFVs.lhs
+++ b/ghc/compiler/coreSyn/CoreFVs.lhs
@@ -9,9 +9,11 @@ module CoreFVs (
        exprsFreeVars,  -- [CoreExpr] -> VarSet
 
        exprSomeFreeVars, exprsSomeFreeVars,
        exprsFreeVars,  -- [CoreExpr] -> VarSet
 
        exprSomeFreeVars, exprsSomeFreeVars,

+       exprFreeNames, exprsFreeNames,

 
 

-       idRuleVars, idFreeVars, idFreeTyVars,
-       ruleRhsFreeVars, ruleLhsFreeNames, ruleLhsFreeIds, 
+       idRuleVars, idFreeVars, idFreeTyVars, 
+       ruleRhsFreeVars, rulesRhsFreeVars,
+       ruleLhsFreeNames, ruleLhsFreeIds, 

 
        CoreExprWithFVs,        -- = AnnExpr Id VarSet
        CoreBindWithFVs,        -- = AnnBind Id VarSet
 
        CoreExprWithFVs,        -- = AnnExpr Id VarSet
        CoreBindWithFVs,        -- = AnnBind Id VarSet

@@ -22,8 +24,11 @@ module CoreFVs (
 #include "HsVersions.h"
 
 import CoreSyn
 #include "HsVersions.h"
 
 import CoreSyn

-import Id              ( Id, idType, idSpecialisation )
+import Id              ( Id, idType, idSpecialisation, isLocalId )
+import IdInfo          ( specInfoFreeVars )

 import NameSet
 import NameSet

+import UniqFM          ( delFromUFM )
+import Name            ( isExternalName )

 import VarSet
 import Var             ( Var, isId, isLocalVar, varName )
 import Type            ( tyVarsOfType )
 import VarSet
 import Var             ( Var, isId, isLocalVar, varName )
 import Type            ( tyVarsOfType )

@@ -70,8 +75,8 @@ type InterestingVarFun = Var -> Bool  -- True <=> interesting
 
 \begin{code}
 type FV = InterestingVarFun 
 
 \begin{code}
 type FV = InterestingVarFun 

-         -> VarSet             -- In scope
-         -> VarSet             -- Free vars
+       -> VarSet               -- In scope
+       -> VarSet               -- Free vars

 
 union :: FV -> FV -> FV
 union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope
 
 union :: FV -> FV -> FV
 union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope

@@ -79,21 +84,40 @@ union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand
 noVars :: FV
 noVars fv_cand in_scope = emptyVarSet
 
 noVars :: FV
 noVars fv_cand in_scope = emptyVarSet
 

--- At a variable occurrence, add in any free variables of its rule rhss
--- Curiously, we gather the Id's free *type* variables from its binding
--- site, but its free *rule-rhs* variables from its usage sites.  This
--- 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
+--     Comment about obselete code
+-- We used to gather the free variables the RULES at a variable occurrence
+-- with the following cryptic comment:
+--     "At a variable occurrence, add in any free variables of its rule rhss
+--     Curiously, we gather the Id's free *type* variables from its binding
+--     site, but its free *rule-rhs* variables from its usage sites.  This
+--     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"
+-- Not only is this "weird", but it's also pretty bad because it can make
+-- a function seem more recursive than it is.  Suppose
+--     f  = ...g...
+--     g  = ...
+--         RULE g x = ...f...
+-- Then f is not mentioned in its own RHS, and needn't be a loop breaker
+-- (though g may be).  But if we collect the rule fvs from g's occurrence,
+-- it looks as if f mentions itself.  (This bites in the eftInt/eftIntFB
+-- code in GHC.Enum.)
+-- 
+-- Anyway, it seems plain wrong.  The RULE is like an extra RHS for the
+-- function, so its free variables belong at the definition site.
+--
+-- Deleted code looked like
+--     foldVarSet add_rule_var var_itself_set (idRuleVars var)
+--     add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var
+--                         | otherwise                    = set
+--     SLPJ Feb06
+

 oneVar :: Id -> FV
 oneVar var fv_cand in_scope
   = ASSERT( isId var ) 
 oneVar :: Id -> FV
 oneVar var fv_cand in_scope
   = 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
-    add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var
-                        | otherwise                    = set
+    if keep_it fv_cand in_scope var 
+    then unitVarSet var
+    else emptyVarSet

 
 someVars :: VarSet -> FV
 someVars vars fv_cand in_scope
 
 someVars :: VarSet -> FV
 someVars vars fv_cand in_scope

@@ -127,7 +151,6 @@ 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 (App fun arg)   = expr_fvs fun `union` expr_fvs arg
 expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
 

--- 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)
 expr_fvs (Case scrut bndr ty alts)
   = expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr  
       (foldr (union . alt_fvs) noVars alts)

@@ -135,12 +158,18 @@ expr_fvs (Case scrut bndr ty alts)
     alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
 
 expr_fvs (Let (NonRec bndr rhs) body)
     alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
 
 expr_fvs (Let (NonRec bndr rhs) body)

-  = expr_fvs rhs `union` addBndr bndr (expr_fvs body)
+  = rhs_fvs (bndr, rhs) `union` addBndr bndr (expr_fvs body)

 
 expr_fvs (Let (Rec pairs) body)
 
 expr_fvs (Let (Rec pairs) body)

-  = addBndrs bndrs (foldr (union . expr_fvs) (expr_fvs body) rhss)
-  where
-    (bndrs,rhss) = unzip pairs
+  = addBndrs (map fst pairs) 
+            (foldr (union . rhs_fvs) (expr_fvs body) pairs)
+
+---------
+rhs_fvs (bndr, rhs) = expr_fvs rhs `union` someVars (idRuleVars bndr)
+       -- Treat any RULES as extra RHSs of the binding
+
+---------
+exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs

 \end{code}
 
 
 \end{code}
 
 

@@ -150,7 +179,7 @@ expr_fvs (Let (Rec pairs) body)
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-exprFreeNames finds the free *names* of an expression, notably
+exprFreeNames finds the free *external* *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
 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

@@ -159,40 +188,37 @@ T is defined in this module; we want to avoid declaring that a rule like
 is an orphan.  Of course it isn't, an declaring it an orphan would
 make the whole module an orphan module, which is bad.
 
 is an orphan.  Of course it isn't, an declaring it an orphan would
 make the whole module an orphan module, which is bad.
 

+There's no need to delete local binders, because they will all
+be *internal* names.
+

 \begin{code}
 \begin{code}

-ruleLhsFreeNames :: IdCoreRule -> NameSet
-ruleLhsFreeNames (fn, BuiltinRule _ _) = unitNameSet (varName fn)
-ruleLhsFreeNames (fn, Rule _ _ tpl_vars tpl_args rhs)
-  = addOneToNameSet (exprsFreeNames tpl_args `del_binders` tpl_vars) (varName fn)
+ruleLhsFreeNames :: CoreRule -> NameSet
+ruleLhsFreeNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn
+ruleLhsFreeNames (Rule { ru_fn = fn, ru_bndrs = tpl_vars, ru_args = tpl_args })
+  = addOneToNameSet (exprsFreeNames tpl_args) fn

 
 exprFreeNames :: CoreExpr -> NameSet
 
 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
+-- Find the free *external* names of an expression
+exprFreeNames e
+  = go e
+  where
+    go (Var v) 
+      | isExternalName n    = unitNameSet n
+      | otherwise          = emptyNameSet
+      where n = varName v
+    go (Lit _)                     = emptyNameSet
+    go (Type ty)           = tyClsNamesOfType ty       -- Don't need free tyvars
+    go (App e1 e2)         = go e1 `unionNameSets` go e2
+    go (Lam v e)           = go e `delFromNameSet` varName v
+    go (Note n e)          = go e   
+    go (Let (NonRec b r) e) = go e `unionNameSets` go r
+    go (Let (Rec prs) e)    = exprsFreeNames (map snd prs) `unionNameSets` go e
+    go (Case e b ty as)     = go e `unionNameSets` tyClsNamesOfType ty 
+                              `unionNameSets` unionManyNameSets (map go_alt as)
+
+    go_alt (_,_,r) = go r

 
 exprsFreeNames es = foldr (unionNameSets . exprFreeNames) emptyNameSet es
 
 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}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -204,18 +230,26 @@ del_binders names bndrs = foldl (\s b -> delFromNameSet s (varName b)) names bnd
 
 \begin{code}
 ruleRhsFreeVars :: CoreRule -> VarSet
 
 \begin{code}
 ruleRhsFreeVars :: CoreRule -> VarSet

-ruleRhsFreeVars (BuiltinRule _ _) = noFVs
-ruleRhsFreeVars (Rule str _ tpl_vars tpl_args rhs)
-  = rule_fvs isLocalVar emptyVarSet
+ruleRhsFreeVars (BuiltinRule {}) = noFVs
+ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs })
+  = delFromUFM fvs fn
+       -- Hack alert!
+       -- Don't include the Id in its own rhs free-var set.
+       -- Otherwise the occurrence analyser makes bindings recursive
+       -- that shoudn't be.  E.g.
+       --      RULE:  f (f x y) z  ==>  f x (f y z)

   where
   where

-    rule_fvs = addBndrs tpl_vars (expr_fvs rhs)
+    fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
+
+rulesRhsFreeVars :: [CoreRule] -> VarSet
+rulesRhsFreeVars rules
+  = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet rules

 
 ruleLhsFreeIds :: CoreRule -> VarSet
 
 ruleLhsFreeIds :: CoreRule -> VarSet

--- This finds all the free Ids on the LHS of the rule
--- *including* imported ids
-ruleLhsFreeIds (BuiltinRule _ _) = noFVs
-ruleLhsFreeIds (Rule _ _ tpl_vars tpl_args rhs)
-  = foldl delVarSet (exprsSomeFreeVars isId tpl_args) tpl_vars
+-- This finds all locally-defined free Ids on the LHS of the rule
+ruleLhsFreeIds (BuiltinRule {}) = noFVs
+ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
+  = addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet

 \end{code}
 
 
 \end{code}
 
 

@@ -285,11 +319,11 @@ 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)
 -- 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
+--  | isLocalId id = tyVarsOfType (idType id)
+--  | otherwise    = emptyVarSet

 
 idRuleVars ::Id -> VarSet
 
 idRuleVars ::Id -> VarSet

-idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id)
+idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)

 \end{code}
 
 
 \end{code}