X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreFVs.lhs;h=88509f90f32c8a63e2896fb495dc66daa7405851;hp=3ff583ee2006c02f5a2c3c1ab2f43f80b1be685c;hb=f8f0e76ad302fda30196ebc9230e5fcbc97be537;hpb=6a944ae7fe1e8e2e456c68717188463263f8978f

diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs
index 3ff583e..88509f9 100644
--- a/compiler/coreSyn/CoreFVs.lhs
+++ b/compiler/coreSyn/CoreFVs.lhs
@@ -23,14 +23,13 @@ module CoreFVs (
         -- * Selective free variables of expressions
         InterestingVarFun,
 	exprSomeFreeVars, exprsSomeFreeVars,
-	exprFreeNames, exprsFreeNames,
 
         -- * Free variables of Rules, Vars and Ids
         varTypeTyVars, varTypeTcTyVars, 
 	idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
-	idRuleVars, idRuleRhsVars,
+        idRuleVars, idRuleRhsVars, stableUnfoldingVars,
 	ruleRhsFreeVars, rulesFreeVars,
-	ruleLhsFreeNames, ruleLhsFreeIds, 
+	ruleLhsOrphNames, ruleLhsFreeIds, 
 
         -- * Core syntax tree annotation with free variables
 	CoreExprWithFVs,	-- = AnnExpr Id VarSet
@@ -50,7 +49,9 @@ import Name
 import VarSet
 import Var
 import TcType
+import Coercion
 import Util
+import BasicTypes( Activation )
 import Outputable
 \end{code}
 
@@ -179,12 +180,13 @@ addBndrs bndrs fv = foldr addBndr fv bndrs
 expr_fvs :: CoreExpr -> FV
 
 expr_fvs (Type ty) 	 = someVars (tyVarsOfType ty)
+expr_fvs (Coercion co)   = someVars (tyCoVarsOfCo co)
 expr_fvs (Var var) 	 = oneVar var
 expr_fvs (Lit _)         = noVars
 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 (Cast expr co)  = expr_fvs expr `union` someVars (tyVarsOfType co)
+expr_fvs (Cast expr co)  = expr_fvs expr `union` someVars (tyCoVarsOfCo co)
 
 expr_fvs (Case scrut bndr ty alts)
   = expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr  
@@ -218,7 +220,7 @@ exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs
 %************************************************************************
 
 \begin{code}
--- | Similar to 'exprFreeNames'. However, this is used when deciding whether 
+-- | ruleLhsOrphNames 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:
 -- 
@@ -226,18 +228,20 @@ exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs
 --
 -- is an orphan. Of course it isn't, and declaring it an orphan would
 -- make the whole module an orphan module, which is bad.
-ruleLhsFreeNames :: CoreRule -> NameSet
-ruleLhsFreeNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn
-ruleLhsFreeNames (Rule { ru_fn = fn, ru_args = tpl_args })
-  = addOneToNameSet (exprsFreeNames tpl_args) fn
+ruleLhsOrphNames :: CoreRule -> NameSet
+ruleLhsOrphNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn
+ruleLhsOrphNames (Rule { ru_fn = fn, ru_args = tpl_args })
+  = addOneToNameSet (exprsOrphNames tpl_args) fn
+		-- No need to delete bndrs, because
+		-- exprsOrphNames finds only External names
 
 -- | Finds the free /external/ names of an expression, notably
 -- including the names of type constructors (which of course do not show
 -- up in 'exprFreeVars').
-exprFreeNames :: CoreExpr -> NameSet
+exprOrphNames :: CoreExpr -> NameSet
 -- There's no need to delete local binders, because they will all
 -- be /internal/ names.
-exprFreeNames e
+exprOrphNames e
   = go e
   where
     go (Var v) 
@@ -245,21 +249,22 @@ exprFreeNames e
       | otherwise	    = emptyNameSet
       where n = idName v
     go (Lit _) 	   	    = emptyNameSet
-    go (Type ty)   	    = tyClsNamesOfType ty	-- Don't need free tyvars
+    go (Type ty)   	    = orphNamesOfType ty	-- Don't need free tyvars
+    go (Coercion co)        = orphNamesOfCo co
     go (App e1 e2) 	    = go e1 `unionNameSets` go e2
     go (Lam v e)   	    = go e `delFromNameSet` idName v
     go (Note _ e)           = go e
-    go (Cast e co)          = go e `unionNameSets` tyClsNamesOfType co
+    go (Cast e co)          = go e `unionNameSets` orphNamesOfCo co
     go (Let (NonRec _ r) e) = go e `unionNameSets` go r
-    go (Let (Rec prs) e)    = exprsFreeNames (map snd prs) `unionNameSets` go e
-    go (Case e _ ty as)     = go e `unionNameSets` tyClsNamesOfType ty
+    go (Let (Rec prs) e)    = exprsOrphNames (map snd prs) `unionNameSets` go e
+    go (Case e _ ty as)     = go e `unionNameSets` orphNamesOfType ty
                               `unionNameSets` unionManyNameSets (map go_alt as)
 
     go_alt (_,_,r) = go r
 
--- | Finds the free /external/ names of several expressions: see 'exprFreeNames' for details
-exprsFreeNames :: [CoreExpr] -> NameSet
-exprsFreeNames es = foldr (unionNameSets . exprFreeNames) emptyNameSet es
+-- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details
+exprsOrphNames :: [CoreExpr] -> NameSet
+exprsOrphNames es = foldr (unionNameSets . exprOrphNames) emptyNameSet es
 \end{code}
 
 %************************************************************************
@@ -285,6 +290,20 @@ ruleFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args
   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
@@ -376,15 +395,15 @@ varTypeTyVars :: Var -> TyVarSet
 -- Find the type variables free in the type of the variable
 -- Remember, coercion variables can mention type variables...
 varTypeTyVars var
-  | isLocalId var || isCoVar var = tyVarsOfType (idType var)
-  | otherwise = emptyVarSet	-- Global Ids and non-coercion TyVars
+  | isLocalId var = tyVarsOfType (idType var)
+  | otherwise     = emptyVarSet	-- Global Ids and non-coercion TyVars
 
 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
+  | isLocalId var = tcTyVarsOfType (idType var)
+  | otherwise     = emptyVarSet	-- Global Ids and non-coercion TyVars
 
 idFreeVars :: Id -> VarSet
 -- Type variables, rule variables, and inline variables
@@ -406,25 +425,19 @@ idRuleAndUnfoldingVars id = ASSERT( isId id)
 idRuleVars ::Id -> VarSet  -- Does *not* include CoreUnfolding vars
 idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
 
-idRuleRhsVars :: Id -> VarSet	 -- Does *not* include the CoreUnfolding vars
--- Just the variables free on the *rhs* of a rule
--- See Note [Choosing loop breakers] in Simplify.lhs
-idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars) 
-			 emptyVarSet
-			 (idCoreRules 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
-  = case realIdUnfolding id of
-      CoreUnfolding { uf_tmpl = rhs, uf_guidance = InlineRule {} }
-	                   -> exprFreeVars rhs
-      DFunUnfolding _ args -> exprsFreeVars args
-      _                    -> emptyVarSet
+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}
 
 
@@ -500,12 +513,11 @@ freeVars (Let (Rec binds) body)
     body2     = freeVars body
     body_fvs  = freeVarsOf body2
 
-
 freeVars (Cast expr co)
-  = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 co)
+  = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 (cfvs, co))
   where
     expr2 = freeVars expr
-    cfvs  = tyVarsOfType co
+    cfvs  = tyCoVarsOfCo co
 
 freeVars (Note other_note expr)
   = (freeVarsOf expr2, AnnNote other_note expr2)
@@ -513,5 +525,7 @@ freeVars (Note other_note expr)
     expr2 = freeVars expr
 
 freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)
+
+freeVars (Coercion co) = (tyCoVarsOfCo co, AnnCoercion co)
 \end{code}