X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FSpecialise.lhs;h=0e66b0bc7820d7cd4dfa1d7ac42e6f7f83727416;hb=9512557e2ad1800146ff1931748cda283c267026;hp=086e7b0954ebdff94d2c75eeecf00308a646fc03;hpb=dd313897eb9a14bcc7b81f97e4f2292c30039efd;p=ghc-hetmet.git

diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index 086e7b0..0e66b0b 100644
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -18,12 +18,11 @@ import CoreSubst	( Subst, mkEmptySubst, extendTvSubstList, lookupIdSubst,
 			  substBndr, substBndrs, substTy, substInScope,
 			  cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs
 			) 
-import Var		( zapSpecPragmaId )
 import VarSet
 import VarEnv
 import CoreSyn
 import CoreUtils	( applyTypeToArgs, mkPiTypes )
-import CoreFVs		( exprFreeVars, exprsFreeVars )
+import CoreFVs		( exprFreeVars, exprsFreeVars, idRuleVars )
 import CoreTidy		( tidyRules )
 import CoreLint		( showPass, endPass )
 import Rules		( addIdSpecialisations, mkLocalRule, lookupRule, emptyRuleBase, rulesOfBinds )
@@ -801,7 +800,7 @@ specDefn subst calls (fn, rhs)
     let
 	(spec_defns, spec_uds, spec_rules) = unzip3 stuff
 
-	fn' = addIdSpecialisations zapped_fn spec_rules
+	fn' = addIdSpecialisations fn spec_rules
     in
     returnSM ((fn',rhs'), 
 	      spec_defns, 
@@ -809,14 +808,9 @@ specDefn subst calls (fn, rhs)
 
   | otherwise	-- No calls or RHS doesn't fit our preconceptions
   = specExpr subst rhs			`thenSM` \ (rhs', rhs_uds) ->
-    returnSM ((zapped_fn, rhs'), [], rhs_uds)
+    returnSM ((fn, rhs'), [], rhs_uds)
   
   where
-    zapped_fn		 = zapSpecPragmaId fn
-	-- If the fn is a SpecPragmaId, make it discardable
-	-- It's role as a holder for a call instance is o'er
-	-- But it might be alive for some other reason by now.
-
     fn_type	       = idType fn
     (tyvars, theta, _) = tcSplitSigmaTy fn_type
     n_tyvars	       = length tyvars
@@ -1050,11 +1044,16 @@ zapCalls ids uds = uds {calls = delListFromFM (calls uds) ids}
 
 mkDB bind = (bind, bind_fvs bind)
 
-bind_fvs (NonRec bndr rhs) = exprFreeVars rhs
+bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs)
 bind_fvs (Rec prs)	   = foldl delVarSet rhs_fvs bndrs
 			   where
 			     bndrs = map fst prs
-			     rhs_fvs = unionVarSets [exprFreeVars rhs | (bndr,rhs) <- prs]
+			     rhs_fvs = unionVarSets (map pair_fvs prs)
+
+pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idRuleVars bndr
+	-- Don't forget variables mentioned in the
+	-- rules of the bndr.  C.f. OccAnal.addRuleUsage
+
 
 addDictBind (dict,rhs) uds = uds { dict_binds = mkDB (NonRec dict rhs) `consBag` dict_binds uds }