\section[CoreRules]{Transformation rules}
\begin{code}
+{-# 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/Commentary/CodingStyle#Warnings
+-- for details
+
module Rules (
RuleBase, emptyRuleBase, mkRuleBase, extendRuleBaseList,
unionRuleBase, pprRuleBase, ruleCheckProgram,
import CoreSyn -- All of it
import OccurAnal ( occurAnalyseExpr )
-import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesRhsFreeVars )
+import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars )
import CoreUnfold ( isCheapUnfolding, unfoldingTemplate )
-import CoreUtils ( tcEqExprX )
+import CoreUtils ( tcEqExprX, exprType )
import PprCore ( pprRules )
-import Type ( TvSubstEnv )
+import Type ( Type, TvSubstEnv )
import Coercion ( coercionKind )
import TcType ( tcSplitTyConApp_maybe )
import CoreTidy ( tidyRules )
-import Id ( Id, idUnfolding, isLocalId, isGlobalId, idName,
- idSpecialisation, idCoreRules, setIdSpecialisation )
+import Id
import IdInfo ( SpecInfo( SpecInfo ) )
import Var ( Var )
-import VarEnv ( IdEnv, InScopeSet, emptyTidyEnv,
- emptyInScopeSet, mkInScopeSet,
- emptyVarEnv, lookupVarEnv, extendVarEnv,
- nukeRnEnvL, mkRnEnv2, rnOccR, rnOccL, inRnEnvR,
- rnBndrR, rnBndr2, rnBndrL, rnBndrs2,
- rnInScope, extendRnInScopeList, lookupRnInScope )
+import VarEnv
import VarSet
-import Name ( Name, NamedThing(..), nameOccName )
+import Name ( Name, NamedThing(..) )
import NameEnv
import Unify ( ruleMatchTyX, MatchEnv(..) )
import BasicTypes ( Activation, CompilerPhase, isActive )
+import StaticFlags ( opt_PprStyle_Debug )
import Outputable
import FastString
import Maybes
import OrdList
import Bag
import Util
-import List hiding( mapAccumL ) -- Also defined in Util
+import Data.List
\end{code}
= Rule { ru_name = name, ru_fn = fn, ru_act = act,
ru_bndrs = bndrs, ru_args = args,
ru_rhs = rhs, ru_rough = roughTopNames args,
- ru_orph = Just (nameOccName fn), ru_local = True }
+ ru_local = True }
--------------
roughTopNames :: [CoreExpr] -> [Maybe Name]
-- 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
\begin{code}
mkSpecInfo :: [CoreRule] -> SpecInfo
-mkSpecInfo rules = SpecInfo rules (rulesRhsFreeVars rules)
+mkSpecInfo rules = SpecInfo rules (rulesFreeVars rules)
extendSpecInfo :: SpecInfo -> [CoreRule] -> SpecInfo
extendSpecInfo (SpecInfo rs1 fvs1) rs2
- = SpecInfo (rs2 ++ rs1) (rulesRhsFreeVars rs2 `unionVarSet` fvs1)
+ = SpecInfo (rs2 ++ rs1) (rulesFreeVars rs2 `unionVarSet` fvs1)
addSpecInfo :: SpecInfo -> SpecInfo -> SpecInfo
addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2)
%* *
%************************************************************************
+Note [Extra args in rule matching]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we find a matching rule, we return (Just (rule, rhs)),
+but the rule firing has only consumed as many of the input args
+as the ruleArity says. It's up to the caller to keep track
+of any left-over args. E.g. if you call
+ lookupRule ... f [e1, e2, e3]
+and it returns Just (r, rhs), where r has ruleArity 2
+then the real rewrite is
+ f e1 e2 e3 ==> rhs e3
+
+You might think it'd be cleaner for lookupRule to deal with the
+leftover arguments, by applying 'rhs' to them, but the main call
+in the Simplifier works better as it is. Reason: the 'args' passed
+to lookupRule are the result of a lazy substitution
+
\begin{code}
lookupRule :: (Activation -> Bool) -> InScopeSet
-> RuleBase -- Imported rules
-> 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 = 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]) $
+ | 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)
+ else empty,
+ 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
Just e -> e
other -> unbound tmpl_var'
- unbound var = pprPanic "Template variable unbound in rewrite rule" (ppr var)
+ unbound var = pprPanic "Template variable unbound in rewrite rule"
+ (ppr var $$ ppr tmpl_vars $$ ppr tmpl_vars' $$ ppr tmpl_es $$ ppr target_es)
\end{code}
Note [Template binders]
~~~~~~~~~~~~~~~~~~~~~~~
Consider the following match:
Template: forall x. f x
- Taret: f (x+1)
-This should succeed, because the template variable 'x' has nothing to do with
-the 'x' in the target.
+ Target: f (x+1)
+This should succeed, because the template variable 'x' has
+nothing to do with the 'x' in the target.
+
+On reflection, this case probably does just work, but this might not
+ Template: forall x. f (\x.x)
+ Target: f (\y.y)
+Here we want to clone when we find the \x, but to know that x must be in scope
-To achive this, we use rnBndrL to rename the template variables if necessary;
-the renamed ones are the tmpl_vars'
+To achive this, we use rnBndrL to rename the template variables if
+necessary; the renamed ones are the tmpl_vars'
---------------------------------------------
| Just subst <- match_var menv subst v1 e2
= Just subst
+match menv subst e1 (Note n e2)
+ = match menv subst e1 e2
+ -- Note [Notes in RULE matching]
+ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ -- Look through Notes. In particular, we don't want to
+ -- be confused by InlineMe notes. Maybe we should be more
+ -- careful about profiling notes, but for now I'm just
+ -- riding roughshod over them.
+ --- See Note [Notes in call patterns] in SpecConstr
+
-- Here is another important rule: if the term being matched is a
-- variable, we expand it so long as its unfolding is a WHNF
-- (Its occurrence information is not necessarily up to date,
-- See Note [Lookup in-scope]
-- Remember to apply any renaming first (hence rnOccR)
+-- Note [Matching lets]
+-- ~~~~~~~~~~~~~~~~~~~~
-- Matching a let-expression. Consider
-- RULE forall x. f (g x) = <rhs>
-- and target expression
-- We can only do this if
-- (a) Widening the scope of w does not capture any variables
-- We use a conservative test: w is not already in scope
+-- If not, we clone the binders, and substitute
-- (b) The free variables of R are not bound by the part of the
-- target expression outside the let binding; e.g.
-- f (\v. let w = v+1 in g E)
-- Here we obviously cannot float the let-binding for w.
+--
+-- You may think rule (a) would never apply, because rule matching is
+-- mostly invoked from the simplifier, when we have just run substExpr
+-- over the argument, so there will be no shadowing anyway.
+-- The fly in the ointment is that the forall'd variables of the
+-- RULE itself are considered in scope.
+--
+-- I though of various cheapo ways to solve this tiresome problem,
+-- but ended up doing the straightforward thing, which is to
+-- clone the binders if they are in scope. It's tiresome, and
+-- potentially inefficient, because of the calls to substExpr,
+-- but I don't think it'll happen much in pracice.
+
+{- Cases to think about
+ (let x=y+1 in \x. (x,x))
+ --> let x=y+1 in (\x1. (x1,x1))
+ (\x. let x = y+1 in (x,x))
+ --> let x1 = y+1 in (\x. (x1,x1)
+ (let x=y+1 in (x,x), let x=y-1 in (x,x))
+ --> let x=y+1 in let x1=y-1 in ((x,x),(x1,x1))
+
+Watch out!
+ (let x=y+1 in let z=x+1 in (z,z)
+ --> matches (p,p) but watch out that the use of
+ x on z's rhs is OK!
+I'm removing the cloning because that makes the above case
+fail, because the inner let looks as if it has locally-bound vars -}
match menv subst@(tv_subst, id_subst, binds) e1 (Let bind e2)
| all freshly_bound bndrs,
not (any locally_bound bind_fvs)
= match (menv { me_env = rn_env' })
- (tv_subst, id_subst, binds `snocOL` bind)
- e1 e2
+ (tv_subst, id_subst, binds `snocOL` bind')
+ e1 e2'
where
rn_env = me_env menv
- bndrs = bindersOf bind
+ bndrs = bindersOf bind
bind_fvs = varSetElems (bindFreeVars bind)
+ locally_bound x = inRnEnvR rn_env x
freshly_bound x = not (x `rnInScope` rn_env)
- locally_bound x = inRnEnvR rn_env x
+ bind' = bind
+ e2' = e2
rn_env' = extendRnInScopeList rn_env bndrs
+{-
+ (rn_env', bndrs') = mapAccumL rnBndrR rn_env bndrs
+ s_prs = [(bndr, Var bndr') | (bndr,bndr') <- zip bndrs bndrs', bndr /= bndr']
+ subst = mkSubst (rnInScopeSet rn_env) emptyVarEnv (mkVarEnv s_prs)
+ (bind', e2') | null s_prs = (bind, e2)
+ | otherwise = (s_bind, substExpr subst e2)
+ s_bind = case bind of
+ NonRec {} -> NonRec (head bndrs') (head rhss)
+ Rec {} -> Rec (bndrs' `zip` map (substExpr subst) rhss)
+-}
match menv subst (Lit lit1) (Lit lit2)
| lit1 == lit2
= 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
-> Nothing -- Occurs check failure
-- e.g. match forall a. (\x-> a x) against (\y. y y)
- | otherwise -- No renaming to do on e2
- -> Just (tv_subst, extendVarEnv id_subst v1' e2, binds)
-
- Just e2' | tcEqExprX (nukeRnEnvL rn_env) e2' e2
+ | 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 must only match on args that have the right type
+ -- It's actually quite difficult to come up with an example that shows
+ -- you need type matching, esp since matching is left-to-right, so type
+ -- args get matched first. But it's possible (e.g. simplrun008) and
+ -- this is the Right Thing to do
+ -> do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst (idType v1') (exprType e2)
+ -- c.f. match_ty below
+ ; return (tv_subst', extendVarEnv id_subst v1' e2, binds) }
+
+ Just e1' | tcEqExprX (nukeRnEnvL rn_env) e1' e2
-> Just subst
| otherwise
\begin{code}
------------------------------------------
+match_ty :: MatchEnv
+ -> SubstEnv
+ -> Type -- Template
+ -> Type -- Target
+ -> Maybe SubstEnv
match_ty menv (tv_subst, id_subst, binds) ty1 ty2
= do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2
; return (tv_subst', id_subst, binds) }
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