X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FRules.lhs;h=000df944cfcc1907447b9fcc7ebb63a73a74b671;hb=2d4d989711476f786e5fdf00e7d737323eca9e74;hp=bbb678deecc1712556bc3017333bf4d09ccaed1c;hpb=609db9ce4ad70c8cf64350b75da03229a7c33b0f;p=ghc-hetmet.git

diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index bbb678d..000df94 100644
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -35,8 +35,7 @@ import Type		( Type, TvSubstEnv )
 import Coercion         ( coercionKind )
 import TcType		( tcSplitTyConApp_maybe )
 import CoreTidy		( tidyRules )
-import Id		( Id, idUnfolding, isLocalId, isGlobalId, idName, idType,
-			  idSpecialisation, idCoreRules, setIdSpecialisation ) 
+import Id
 import IdInfo		( SpecInfo( SpecInfo ) )
 import Var		( Var )
 import VarEnv
@@ -124,11 +123,13 @@ ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
 -- It's only a one-way match; unlike instance matching we 
 -- don't consider unification
 -- 
--- Notice that there is no case
---	ruleCantMatch (Just n1 : ts) (Nothing : as) = True
--- Reason: a local variable 'v' in the actuals might 
--- 	   have an unfolding which is a global.
---	   This quite often happens with case scrutinees.
+-- Notice that [_$_]
+--	ruleCantMatch [Nothing] [Just n2] = False
+--      Reason: a template variable can be instantiated by a constant
+-- Also:
+--	ruleCantMatch [Just n1] [Nothing] = False
+--      Reason: a local variable 'v' in the actuals might [_$_]
+
 ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as
 ruleCantMatch (t       : ts) (a       : as) = ruleCantMatch ts as
 ruleCantMatch ts	     as		    = False
@@ -233,9 +234,11 @@ getRules :: RuleBase -> Id -> [CoreRule]
 	--	(b) rules added in subsequent modules (extra_rules)
 	-- PrimOps, for example, are born with a bunch of rules under (a)
 getRules rule_base fn
-  | isLocalId fn = idCoreRules fn
-  | otherwise    = WARN( null (idCoreRules fn), ppr fn <+> ppr (idCoreRules fn) )
-		   lookupNameEnv rule_base (idName fn) `orElse` []
+  | isLocalId fn  = idCoreRules fn
+  | otherwise     = WARN( not (isPrimOpId fn) && notNull (idCoreRules fn), 
+ 			  ppr fn <+> ppr (idCoreRules fn) )
+		    idCoreRules fn ++ (lookupNameEnv rule_base (idName fn) `orElse` [])
+	-- Only PrimOpIds have rules inside themselves, and perhaps more besides
 
 matchRules :: (Activation -> Bool) -> InScopeSet
 	   -> Id -> [CoreExpr]
@@ -267,20 +270,17 @@ findBest target (rule,ans)   [] = (rule,ans)
 findBest target (rule1,ans1) ((rule2,ans2):prs)
   | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs
   | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs
-#ifdef DEBUG
-  | otherwise = let pp_rule rule 
+  | debugIsOn = let pp_rule rule
 			| opt_PprStyle_Debug = ppr rule
 			| otherwise          = doubleQuotes (ftext (ru_name rule))
 		in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)"
 			 (vcat [if opt_PprStyle_Debug then 
-				   ptext SLIT("Expression to match:") <+> ppr fn <+> sep (map ppr args)
+				   ptext (sLit "Expression to match:") <+> ppr fn <+> sep (map ppr args)
 				else empty,
-				ptext SLIT("Rule 1:") <+> pp_rule rule1, 
-				ptext SLIT("Rule 2:") <+> pp_rule rule2]) $
+				ptext (sLit "Rule 1:") <+> pp_rule rule1, 
+				ptext (sLit "Rule 2:") <+> pp_rule rule2]) $
 		findBest target (rule1,ans1) prs
-#else
   | otherwise = findBest target (rule1,ans1) prs
-#endif
   where
     (fn,args) = target
 
@@ -832,9 +832,9 @@ ruleAppCheck_help phase fn args rules
     check_rule rule = rule_herald rule <> colon <+> rule_info rule
 
     rule_herald (BuiltinRule { ru_name = name })
-	= ptext SLIT("Builtin rule") <+> doubleQuotes (ftext name)
+	= ptext (sLit "Builtin rule") <+> doubleQuotes (ftext name)
     rule_herald (Rule { ru_name = name })
-	= ptext SLIT("Rule") <+> doubleQuotes (ftext name)
+	= ptext (sLit "Rule") <+> doubleQuotes (ftext name)
 
     rule_info rule
 	| Just _ <- matchRule noBlackList emptyInScopeSet args rough_args rule