[project @ 2005-07-28 14:45:55 by simonpj]

[ghc-hetmet.git] / ghc / compiler / specialise / Rules.lhs

diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs
index 6901821..702902f 100644 (file)
--- a/ghc/compiler/specialise/Rules.lhs
+++ b/ghc/compiler/specialise/Rules.lhs
@@ -17,7 +17,7 @@ module Rules (
 #include "HsVersions.h"
 
 import CoreSyn         -- All of it
-import OccurAnal       ( occurAnalyseGlobalExpr )
+import OccurAnal       ( occurAnalyseExpr )
 import CoreFVs         ( exprFreeVars, exprsFreeVars, rulesRhsFreeVars )
 import CoreUnfold      ( isCheapUnfolding, unfoldingTemplate )
 import CoreUtils       ( tcEqExprX )
@@ -39,11 +39,11 @@ import Name         ( Name, NamedThing(..), nameOccName )
 import NameEnv
 import Unify           ( tcMatchTyX, MatchEnv(..) )
 import BasicTypes      ( Activation, CompilerPhase, isActive )
-
 import Outputable
 import FastString
-import Maybe           ( isJust )
+import Maybes          ( isJust, orElse )
 import Bag
+import Util            ( singleton )
 import List            ( isPrefixOf )
 \end{code}
 
@@ -176,9 +176,7 @@ unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2
 
 extendRuleBase :: RuleBase -> CoreRule -> RuleBase
 extendRuleBase rule_base rule
-  = extendNameEnv_C add rule_base (ruleIdName rule) [rule]
-  where
-    add rules _ = rule : rules
+  = extendNameEnv_Acc (:) singleton rule_base (ruleIdName rule) rule
 
 pprRuleBase :: RuleBase -> SDoc
 pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs) 
@@ -199,10 +197,13 @@ lookupRule :: (Activation -> Bool) -> InScopeSet
 lookupRule is_active in_scope rule_base fn args
   = matchRules is_active in_scope fn args rules
   where
-    rules | isLocalId fn = idCoreRules fn
-         | otherwise    = case lookupNameEnv rule_base (idName fn) of
-                               Just rules -> rules
-                               Nothing    -> []
+       -- The rules for an Id come from two places:
+       --      (a) the ones it is born with (idCoreRules fn)
+       --      (b) rules added in subsequent modules (extra_rules)
+       -- PrimOps, for example, are born with a bunch of rules under (a)
+    rules = extra_rules ++ idCoreRules fn
+    extra_rules | isLocalId fn = []
+               | otherwise    = lookupNameEnv rule_base (idName fn) `orElse` []
 
 matchRules :: (Activation -> Bool) -> InScopeSet
           -> Id -> [CoreExpr]
@@ -232,11 +233,15 @@ 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 (rule1,ans1) prs
+#ifdef DEBUG
   | otherwise = pprTrace "Rules.findBest: rule overlap (Rule 1 wins)"
                         (vcat [ptext SLIT("Expression to match:") <+> ppr fn <+> sep (map ppr args),
                                ptext SLIT("Rule 1:") <+> ppr rule1, 
                                ptext SLIT("Rule 2:") <+> ppr rule2]) $
                findBest target (rule1,ans1) prs
+#else
+  | otherwise = findBest target (rule1,ans1) prs
+#endif
   where
     (fn,args) = target
 
@@ -299,7 +304,7 @@ matchRule is_active in_scope args rough_args
                                            `mkApps` tpl_vals
                                            `mkApps` leftovers)
   where
-    rule_fn = occurAnalyseGlobalExpr (mkLams tpl_vars rhs)
+    rule_fn = occurAnalyseExpr (mkLams tpl_vars rhs)
        -- We could do this when putting things into the rulebase, I guess
 \end{code}