Fix bug in roughTopNames

roughTopNames was returning a name that in fact might be
"looked though" by the rule matcher. Result: a rule
that should match was being pre-emptively discarded.

See Note [Care with roughTopName].

Fixes a bug noticed by Pedro (Trac #4918).

1 files changed, 23 insertions, 3 deletions

diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index 128d01fecd..3205542c8e 100644
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -187,8 +187,9 @@ roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of
 			  Just (tc,_) -> Just (getName tc)
 			  Nothing     -> Nothing
 roughTopName (App f _) = roughTopName f
-roughTopName (Var f) | isGlobalId f = Just (idName f)
-		     | otherwise    = Nothing
+roughTopName (Var f)   | isGlobalId f	-- Note [Care with roughTopName]
+                       , isDataConWorkId f || idArity f > 0
+                       = Just (idName f)
 roughTopName _ = Nothing
 
 ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
@@ -209,6 +210,25 @@ ruleCantMatch (_       : ts) (_       : as) = ruleCantMatch ts as
 ruleCantMatch _ 	     _ 		    = False
 \end{code}
 
+Note [Care with roughTopName]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+    module M where { x = a:b }
+    module N where { ...f x...
+                     RULE f (p:q) = ... }
+You'd expect the rule to match, because the matcher can 
+look through the unfolding of 'x'.  So we must avoid roughTopName
+returning 'M.x' for the call (f x), or else it'll say "can't match"
+and we won't even try!!
+
+However, suppose we have
+	 RULE g (M.h x) = ...
+	 foo = ...(g (M.k v))....
+where k is a *function* exported by M.  We never really match
+functions (lambdas) except by name, so in this case it seems like
+a good idea to treat 'M.k' as a roughTopName of the call.
+
+    
 \begin{code}
 pprRulesForUser :: [CoreRule] -> SDoc
 -- (a) tidy the rules
@@ -340,7 +360,7 @@ lookupRule :: (Activation -> Bool)	-- When rule is active
 -- See Note [Extra args in rule matching]
 -- See comments on matchRule
 lookupRule is_active id_unf in_scope fn args rules
-  = -- pprTrace "matchRules" (ppr fn <+> ppr rules) $
+  = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $
     case go [] rules of
 	[]     -> Nothing
 	(m:ms) -> Just (findBest (fn,args) m ms)