\section[CoreRules]{Transformation rules}
\begin{code}
-{-# OPTIONS_GHC -w #-}
+{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
module Rules (
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
-- 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
-> 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)
- 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]
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
= match_ty menv subst ty1 ty2
match menv subst (Cast e1 co1) (Cast e2 co2)
- | (from1, to1) <- coercionKind co1
- , (from2, to2) <- coercionKind co2
- = do { subst1 <- match_ty menv subst to1 to2
- ; subst2 <- match_ty menv subst1 from1 from2
- ; match menv subst2 e1 e2 }
+ = do { subst1 <- match_ty menv subst co1 co2
+ ; match menv subst1 e1 e2 }
{- REMOVING OLD CODE: I think that the above handling for let is
better than the stuff here, which looks
| otherwise -- No renaming to do on e2, because no free var
-- of e2 is in the rnEnvR of the envt
+ -- Note [Matching variable types]
+ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- However, we must match the *types*; e.g.
-- forall (c::Char->Int) (x::Char).
-- f (c x) = "RULE FIRED"
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}
-ruleCheckProgram :: CompilerPhase -> String -> [CoreBind] -> SDoc
+ruleCheckProgram :: CompilerPhase -> String -> RuleBase -> [CoreBind] -> SDoc
-- 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
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 '-')
-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
-- 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
- 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
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