X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreFVs.lhs;h=9abf11f1333b1c9de26f41f3c50a6cc4a41622af;hp=d2d1383e2b4cc23b978938619e66970a0462073f;hb=a3bab0506498db41853543558c52a4fda0d183af;hpb=7c0bfc36a39ab8e181cca97be3e5b21dda9be0cb

diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs
index d2d1383..9abf11f 100644
--- a/compiler/coreSyn/CoreFVs.lhs
+++ b/compiler/coreSyn/CoreFVs.lhs
@@ -16,6 +16,7 @@ Taken quite directly from the Peyton Jones/Lester paper.
 module CoreFVs (
         -- * Free variables of expressions and binding groups
 	exprFreeVars,	-- CoreExpr   -> VarSet	-- Find all locally-defined free Ids or tyvars
+	exprFreeIds,	-- CoreExpr   -> IdSet	-- Find all locally-defined free Ids
 	exprsFreeVars,	-- [CoreExpr] -> VarSet
 	bindFreeVars, 	-- CoreBind   -> VarSet
 
@@ -25,7 +26,9 @@ module CoreFVs (
 	exprFreeNames, exprsFreeNames,
 
         -- * Free variables of Rules, Vars and Ids
-	idRuleVars, idFreeVars, varTypeTyVars, 
+        varTypeTyVars, varTypeTcTyVars, 
+	idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
+        idRuleVars, idRuleRhsVars, stableUnfoldingVars,
 	ruleRhsFreeVars, rulesFreeVars,
 	ruleLhsFreeNames, ruleLhsFreeIds, 
 
@@ -48,6 +51,7 @@ import VarSet
 import Var
 import TcType
 import Util
+import BasicTypes( Activation )
 import Outputable
 \end{code}
 
@@ -71,6 +75,10 @@ but not those that are free in the type of variable occurrence.
 exprFreeVars :: CoreExpr -> VarSet
 exprFreeVars = exprSomeFreeVars isLocalVar
 
+-- | Find all locally-defined free Ids in an expression
+exprFreeIds :: CoreExpr -> IdSet	-- Find all locally-defined free Ids
+exprFreeIds = exprSomeFreeVars isLocalId
+
 -- | Find all locally-defined free Ids or type variables in several expressions
 exprsFreeVars :: [CoreExpr] -> VarSet
 exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet
@@ -194,7 +202,8 @@ expr_fvs (Let (Rec pairs) body)
 
 ---------
 rhs_fvs :: (Id,CoreExpr) -> FV
-rhs_fvs (bndr, rhs) = expr_fvs rhs `union` someVars (bndrRuleVars bndr)
+rhs_fvs (bndr, rhs) = expr_fvs rhs `union` 
+                      someVars (bndrRuleAndUnfoldingVars bndr)
 	-- Treat any RULES as extra RHSs of the binding
 
 ---------
@@ -271,11 +280,26 @@ ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs })
 
 -- | Those variables free in the both the left right hand sides of a rule
 ruleFreeVars :: CoreRule -> VarSet
+ruleFreeVars (BuiltinRule {}) = noFVs
 ruleFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args })
   = delFromUFM fvs fn	-- Note [Rule free var hack]
   where
     fvs = addBndrs bndrs (exprs_fvs (rhs:args)) isLocalVar emptyVarSet
 
+idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet
+-- Just the variables free on the *rhs* of a rule
+idRuleRhsVars is_active id 
+  = foldr (unionVarSet . get_fvs) emptyVarSet (idCoreRules id)
+  where
+    get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs
+                  , ru_rhs = rhs, ru_act = act })
+      | is_active act
+      	    -- See Note [Finding rule RHS free vars] in OccAnal.lhs
+      = delFromUFM fvs fn	 -- Note [Rule free var hack]
+      where
+        fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
+    get_fvs _ = noFVs
+
 -- | Those variables free in the right hand side of several rules
 rulesFreeVars :: [CoreRule] -> VarSet
 rulesFreeVars rules = foldr (unionVarSet . ruleFreeVars) emptyVarSet rules
@@ -334,8 +358,8 @@ delBinderFV :: Var -> VarSet -> VarSet
 
 -- (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
+--
+--	the free variables of b's type
 --
 -- This is really important for some lambdas:
 -- 	In (\x::a -> x) the only mention of "a" is in the binder.
@@ -370,15 +394,46 @@ varTypeTyVars var
   | isLocalId var || isCoVar var = tyVarsOfType (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
+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
 
-idRuleVars ::Id -> VarSet
+idFreeVars :: Id -> VarSet
+-- Type variables, rule variables, and inline variables
+idFreeVars id = ASSERT( isId id) 
+		varTypeTyVars id `unionVarSet`
+	        idRuleAndUnfoldingVars id
+
+bndrRuleAndUnfoldingVars ::Var -> VarSet
+-- A 'let' can bind a type variable, and idRuleVars assumes 
+-- it's seeing an Id. This function tests first.
+bndrRuleAndUnfoldingVars v | isTyCoVar v = emptyVarSet
+	                   | otherwise = idRuleAndUnfoldingVars v
+
+idRuleAndUnfoldingVars :: Id -> VarSet
+idRuleAndUnfoldingVars id = ASSERT( isId id) 
+			    idRuleVars id    `unionVarSet` 
+			    idUnfoldingVars id
+
+idRuleVars ::Id -> VarSet  -- Does *not* include CoreUnfolding vars
 idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
+
+idUnfoldingVars :: Id -> VarSet
+-- Produce free vars for an unfolding, but NOT for an ordinary
+-- (non-inline) unfolding, since it is a dup of the rhs
+-- and we'll get exponential behaviour if we look at both unf and rhs!
+-- But do look at the *real* unfolding, even for loop breakers, else
+-- we might get out-of-scope variables
+idUnfoldingVars id = stableUnfoldingVars (realIdUnfolding id)
+
+stableUnfoldingVars :: Unfolding -> VarSet
+stableUnfoldingVars (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
+  | isStableSource src                       = exprFreeVars rhs
+stableUnfoldingVars (DFunUnfolding _ _ args) = exprsFreeVars (dfunArgExprs args)
+stableUnfoldingVars _                        = emptyVarSet
 \end{code}
 
 
@@ -429,7 +484,9 @@ freeVars (Case scrut bndr ty alts)
 			     rhs2 = freeVars rhs
 
 freeVars (Let (NonRec binder rhs) body)
-  = (freeVarsOf rhs2 `unionFVs` body_fvs `unionFVs` bndrRuleVars binder,
+  = (freeVarsOf rhs2 
+       `unionFVs` body_fvs 
+       `unionFVs` bndrRuleAndUnfoldingVars binder,
 		-- Remember any rules; cf rhs_fvs above
      AnnLet (AnnNonRec binder rhs2) body2)
   where
@@ -445,7 +502,7 @@ freeVars (Let (Rec binds) body)
 
     rhss2     = map freeVars rhss
     rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2
-    all_fvs      = foldr (unionFVs . idRuleVars) rhs_body_fvs binders
+    all_fvs      = foldr (unionFVs . idRuleAndUnfoldingVars) rhs_body_fvs binders
 	-- The "delBinderFV" happens after adding the idSpecVars,
 	-- since the latter may add some of the binders as fvs