(F)SLIT -> (f)sLit in Specialse

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

diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index 24c4004..000df94 100644 (file)
--- 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 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
 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
 -- 
 -- 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
 ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as
 ruleCantMatch (t       : ts) (a       : as) = ruleCantMatch ts as
 ruleCantMatch ts            as             = False

@@ -225,15 +226,19 @@ lookupRule :: (Activation -> Bool) -> InScopeSet
           -> Id -> [CoreExpr] -> Maybe (CoreRule, CoreExpr)
 -- See Note [Extra argsin rule matching]
 lookupRule is_active in_scope rule_base fn args
           -> Id -> [CoreExpr] -> Maybe (CoreRule, CoreExpr)
 -- See Note [Extra argsin rule matching]
 lookupRule is_active in_scope rule_base fn args

-  = matchRules is_active in_scope fn args rules
-  where
+  = matchRules is_active in_scope fn args (getRules rule_base fn)
+
+getRules :: RuleBase -> Id -> [CoreRule]

        -- 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)
        -- 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` []
+getRules rule_base fn
+  | 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]
 
 matchRules :: (Activation -> Bool) -> InScopeSet
           -> Id -> [CoreExpr]

@@ -265,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
 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 
                        | 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,
                                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
                findBest target (rule1,ans1) prs

-#else

   | otherwise = findBest target (rule1,ans1) prs
   | otherwise = findBest target (rule1,ans1) prs

-#endif

   where
     (fn,args) = target
 
   where
     (fn,args) = target
 

@@ -765,16 +767,11 @@ is so important.
 We want to know what sites have rules that could have fired but didn't.
 This pass runs over the tree (without changing it) and reports such.
 
 We want to know what sites have rules that could have fired but didn't.
 This pass runs over the tree (without changing it) and reports such.
 

-NB: we assume that this follows a run of the simplifier, so every Id
-occurrence (including occurrences of imported Ids) is decorated with
-all its (active) rules.  No need to construct a rule base or anything
-like that.
-

 \begin{code}
 \begin{code}

-ruleCheckProgram :: CompilerPhase -> String -> [CoreBind] -> SDoc
+ruleCheckProgram :: CompilerPhase -> String -> RuleBase -> [CoreBind] -> SDoc

 -- Report partial matches for rules beginning 
 -- with the specified string
 -- Report partial matches for rules beginning 
 -- with the specified string

-ruleCheckProgram phase rule_pat binds 
+ruleCheckProgram phase rule_pat rule_base binds 

   | isEmptyBag results
   = text "Rule check results: no rule application sites"
   | otherwise
   | isEmptyBag results
   = text "Rule check results: no rule application sites"
   | otherwise

@@ -783,10 +780,10 @@ ruleCheckProgram phase rule_pat binds
          vcat [ p $$ line | p <- bagToList results ]
         ]
   where
          vcat [ p $$ line | p <- bagToList results ]
         ]
   where

-    results = unionManyBags (map (ruleCheckBind (phase, rule_pat)) binds)
+    results = unionManyBags (map (ruleCheckBind (phase, rule_pat, rule_base)) binds)

     line = text (replicate 20 '-')
          
     line = text (replicate 20 '-')
          

-type RuleCheckEnv = (CompilerPhase, String)    -- Phase and Pattern
+type RuleCheckEnv = (CompilerPhase, String, RuleBase)  -- Phase and Pattern

 
 ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
    -- The Bag returned has one SDoc for each call site found
 
 ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
    -- The Bag returned has one SDoc for each call site found

@@ -815,11 +812,11 @@ ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc
 -- Produce a report for all rules matching the predicate
 -- saying why it doesn't match the specified application
 
 -- Produce a report for all rules matching the predicate
 -- saying why it doesn't match the specified application
 

-ruleCheckFun (phase, pat) fn args
+ruleCheckFun (phase, pat, rule_base) fn args

   | null name_match_rules = emptyBag
   | otherwise            = unitBag (ruleAppCheck_help phase fn args name_match_rules)
   where
   | null name_match_rules = emptyBag
   | otherwise            = unitBag (ruleAppCheck_help phase fn args name_match_rules)
   where

-    name_match_rules = filter match (idCoreRules fn)
+    name_match_rules = filter match (getRules rule_base fn)

     match rule = pat `isPrefixOf` unpackFS (ruleName rule)
 
 ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
     match rule = pat `isPrefixOf` unpackFS (ruleName rule)
 
 ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc

@@ -835,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 })
     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 })
     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
 
     rule_info rule
        | Just _ <- matchRule noBlackList emptyInScopeSet args rough_args rule