\begin{code}
module Rules (
- RuleBase, prepareRuleBase, lookupRule,
- addIdSpecialisations,
- ProtoCoreRule(..), pprProtoCoreRule, orphanRule
+ RuleBase, emptyRuleBase, mkRuleBase, extendRuleBaseList,
+ unionRuleBase, pprRuleBase, ruleCheckProgram,
+
+ mkSpecInfo, extendSpecInfo, addSpecInfo,
+ rulesOfBinds, addIdSpecialisations,
+
+ lookupRule, mkLocalRule, roughTopNames
) where
#include "HsVersions.h"
import CoreSyn -- All of it
-import OccurAnal ( occurAnalyseExpr, tagBinders, UsageDetails )
-import BinderInfo ( markMany )
-import CoreFVs ( exprFreeVars, idRuleVars, ruleSomeLhsFreeVars )
-import CoreUnfold ( Unfolding(..) )
-import CoreUtils ( whnfOrBottom, eqExpr )
-import PprCore ( pprCoreRule )
-import Subst ( Subst, InScopeSet, substBndr, lookupSubst, extendSubst,
- mkSubst, substEnv, setSubstEnv,
- unBindSubst, bindSubstList, unBindSubstList,
- )
-import Id ( Id, getIdUnfolding,
- getIdSpecialisation, setIdSpecialisation,
- setIdNoDiscard, maybeModifyIdInfo, modifyIdInfo
- )
-import IdInfo ( zapLamIdInfo, setSpecInfo, specInfo )
-import Name ( Name, isLocallyDefined )
-import Var ( isTyVar, isId )
+import OccurAnal ( occurAnalyseExpr )
+import CoreFVs ( exprFreeVars, exprsFreeVars, rulesRhsFreeVars )
+import CoreUnfold ( isCheapUnfolding, unfoldingTemplate )
+import CoreUtils ( tcEqExprX )
+import PprCore ( pprRules )
+import Type ( TvSubstEnv )
+import TcType ( tcSplitTyConApp_maybe )
+import CoreTidy ( tidyRules )
+import Id ( Id, idUnfolding, isLocalId, isGlobalId, idName,
+ idSpecialisation, idCoreRules, setIdSpecialisation )
+import IdInfo ( SpecInfo( SpecInfo ) )
+import Var ( Var )
+import VarEnv ( IdEnv, InScopeSet, emptyTidyEnv,
+ emptyInScopeSet, mkInScopeSet, extendInScopeSetList,
+ emptyVarEnv, lookupVarEnv, extendVarEnv,
+ nukeRnEnvL, mkRnEnv2, rnOccR, rnOccL, inRnEnvR,
+ rnBndrR, rnBndr2, rnBndrL, rnBndrs2 )
import VarSet
-import VarEnv
-import Type ( mkTyVarTy, getTyVar_maybe )
-import qualified Unify ( match )
-import CmdLineOpts ( opt_D_dump_simpl, opt_D_verbose_core2core )
-
-import UniqFM
-import ErrUtils ( dumpIfSet )
+import Name ( Name, NamedThing(..), nameOccName )
+import NameEnv
+import Unify ( ruleMatchTyX, MatchEnv(..) )
+import BasicTypes ( Activation, CompilerPhase, isActive )
import Outputable
-import Maybes ( maybeToBool )
-import List ( partition )
-import Util ( sortLt )
+import FastString
+import Maybes ( isJust, orElse )
+import Bag
+import Util ( singleton )
+import List ( isPrefixOf )
\end{code}
where pi' :: Lift Int# is the specialised version of pi.
+\begin{code}
+mkLocalRule :: RuleName -> Activation
+ -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
+-- Used to make CoreRule for an Id defined in this module
+mkLocalRule name act fn bndrs args rhs
+ = 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 }
+
+--------------
+roughTopNames :: [CoreExpr] -> [Maybe Name]
+roughTopNames args = map roughTopName args
+
+roughTopName :: CoreExpr -> Maybe Name
+-- Find the "top" free name of an expression
+-- a) the function in an App chain (if a GlobalId)
+-- b) the TyCon in a type
+-- This is used for the fast-match-check for rules;
+-- if the top names don't match, the rest can't
+roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of
+ Just (tc,_) -> Just (getName tc)
+ Nothing -> Nothing
+roughTopName (App f a) = roughTopName f
+roughTopName (Var f) | isGlobalId f = Just (idName f)
+ | otherwise = Nothing
+roughTopName other = Nothing
+
+ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
+-- (ruleCantMatch tpl actual) returns True only if 'actual'
+-- definitely can't match 'tpl' by instantiating 'tpl'.
+-- It's only a one-way match; unlike instance matching we
+-- don't consider unification
+ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as
+ruleCantMatch (Just n1 : ts) (Nothing : as) = True
+ruleCantMatch (t : ts) (a : as) = ruleCantMatch ts as
+ruleCantMatch ts as = False
+\end{code}
+
+
+%************************************************************************
+%* *
+ SpecInfo: the rules in an IdInfo
+%* *
+%************************************************************************
+
+\begin{code}
+mkSpecInfo :: [CoreRule] -> SpecInfo
+mkSpecInfo rules = SpecInfo rules (rulesRhsFreeVars rules)
+
+extendSpecInfo :: SpecInfo -> [CoreRule] -> SpecInfo
+extendSpecInfo (SpecInfo rs1 fvs1) rs2
+ = SpecInfo (rs2 ++ rs1) (rulesRhsFreeVars rs2 `unionVarSet` fvs1)
+
+addSpecInfo :: SpecInfo -> SpecInfo -> SpecInfo
+addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2)
+ = SpecInfo (rs1 ++ rs2) (fvs1 `unionVarSet` fvs2)
+
+addIdSpecialisations :: Id -> [CoreRule] -> Id
+addIdSpecialisations id rules
+ = setIdSpecialisation id $
+ extendSpecInfo (idSpecialisation id) rules
+
+rulesOfBinds :: [CoreBind] -> [CoreRule]
+rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds
+\end{code}
+
+
+%************************************************************************
+%* *
+ RuleBase
+%* *
+%************************************************************************
+
+\begin{code}
+type RuleBase = NameEnv [CoreRule]
+ -- Maps (the name of) an Id to its rules
+ -- The rules are are unordered;
+ -- we sort out any overlaps on lookup
+
+emptyRuleBase = emptyNameEnv
+
+mkRuleBase :: [CoreRule] -> RuleBase
+mkRuleBase rules = extendRuleBaseList emptyRuleBase rules
+
+extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase
+extendRuleBaseList rule_base new_guys
+ = foldl extendRuleBase rule_base new_guys
+
+unionRuleBase :: RuleBase -> RuleBase -> RuleBase
+unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2
+
+extendRuleBase :: RuleBase -> CoreRule -> RuleBase
+extendRuleBase rule_base rule
+ = extendNameEnv_Acc (:) singleton rule_base (ruleIdName rule) rule
+
+pprRuleBase :: RuleBase -> SDoc
+pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs)
+ | rs <- nameEnvElts rules ]
+\end{code}
+
%************************************************************************
%* *
%************************************************************************
\begin{code}
-matchRules :: InScopeSet -> [CoreRule] -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr])
+lookupRule :: (Activation -> Bool) -> InScopeSet
+ -> RuleBase -- Imported rules
+ -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
+lookupRule is_active in_scope rule_base fn args
+ = matchRules is_active in_scope fn args rules
+ where
+ -- 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]
+ -> [CoreRule] -> Maybe (RuleName, CoreExpr)
-- See comments on matchRule
-matchRules in_scope [] args = Nothing
-matchRules in_scope (rule:rules) args
- = case matchRule in_scope rule args of
- Just result -> Just result
- Nothing -> matchRules in_scope rules args
+matchRules is_active in_scope fn args rules
+ = case go [] rules of
+ [] -> Nothing
+ (m:ms) -> Just (case findBest (fn,args) m ms of
+ (rule, ans) -> (ru_name rule, ans))
+ where
+ rough_args = map roughTopName args
+
+ go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]
+ go ms [] = ms
+ go ms (r:rs) = case (matchRule is_active in_scope args rough_args r) of
+ Just e -> go ((r,e):ms) rs
+ Nothing -> go ms rs
+
+findBest :: (Id, [CoreExpr])
+ -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)
+-- All these pairs matched the expression
+-- Return the pair the the most specific rule
+-- The (fn,args) is just for overlap reporting
+
+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
+
+isMoreSpecific :: CoreRule -> CoreRule -> Bool
+isMoreSpecific (BuiltinRule {}) r2 = True
+isMoreSpecific r1 (BuiltinRule {}) = False
+isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 })
+ (Rule { ru_bndrs = bndrs2, ru_args = args2 })
+ = isJust (matchN in_scope bndrs2 args2 args1)
+ where
+ in_scope = mkInScopeSet (mkVarSet bndrs1)
+ -- Actually we should probably include the free vars
+ -- of rule1's args, but I can't be bothered
+noBlackList :: Activation -> Bool
+noBlackList act = False -- Nothing is black listed
-matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr])
+matchRule :: (Activation -> Bool) -> InScopeSet
+ -> [CoreExpr] -> [Maybe Name]
+ -> CoreRule -> Maybe CoreExpr
--- If (matchRule rule args) returns Just (name,rhs,args')
+-- If (matchRule rule args) returns Just (name,rhs)
-- then (f args) matches the rule, and the corresponding
--- rewritten RHS is (rhs args').
+-- rewritten RHS is rhs
--
-- The bndrs and rhs is occurrence-analysed
--
-- map (f.g) x) -- rhs
--
-- Then the call: matchRule the_rule [e1,map e2 e3]
--- = Just ("map/map", \f,g,x -> rhs, [e1,e2,e3])
+-- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3)
--
-- Any 'surplus' arguments in the input are simply put on the end
-- of the output.
---
--- ASSUMPTION (A):
--- No variable free in the template is bound in the target
-
-matchRule in_scope (Rule rn tpl_vars tpl_args rhs) args
- = go tpl_args args (mkSubst in_scope emptySubstEnv)
- where
- tpl_var_set = mkVarSet tpl_vars
-
- -----------------------
- -- Do the business
- go (tpl_arg:tpl_args) (arg:args) subst = match tpl_arg arg tpl_var_set (go tpl_args args) subst
-
- -- Two easy ways to terminate
- go [] [] subst = Just (rn, mkLams tpl_vars rhs, mk_result_args subst tpl_vars)
- go [] args subst = Just (rn, mkLams tpl_vars rhs, mk_result_args subst tpl_vars ++ args)
-
- -- One tiresome way to terminate: check for excess unmatched
- -- template arguments
- go tpl_args [] subst
- = case eta_complete tpl_args (mkVarSet leftovers) of
- Just leftovers' -> Just (rn, mkLams done (mkLams leftovers' rhs),
- mk_result_args subst done)
- Nothing -> Nothing -- Failure
- where
- (done, leftovers) = partition (\v -> maybeToBool (lookupSubstEnv subst_env v))
- (map zapOccInfo tpl_vars)
- -- Zap the occ info
- subst_env = substEnv subst
-
- -----------------------
- eta_complete [] vars = ASSERT( isEmptyVarSet vars )
- Just []
- eta_complete (Type ty:tpl_args) vars
- = case getTyVar_maybe ty of
- Just tv | tv `elemVarSet` vars
- -> case eta_complete tpl_args (vars `delVarSet` tv) of
- Just vars' -> Just (tv:vars')
- Nothing -> Nothing
- other -> Nothing
-
- eta_complete (Var v:tpl_args) vars
- | v `elemVarSet` vars
- = case eta_complete tpl_args (vars `delVarSet` v) of
- Just vars' -> Just (v:vars')
- Nothing -> Nothing
-
- eta_complete other vars = Nothing
-
- -----------------------
- mk_result_args subst vs = map go vs
- where
- senv = substEnv subst
- go v = case lookupSubstEnv senv v of
- Just (DoneEx ex) -> ex
- Just (DoneTy ty) -> Type ty
- -- Substitution should bind them all!
-
-zapOccInfo bndr | isTyVar bndr = bndr
- | otherwise = maybeModifyIdInfo zapLamIdInfo bndr
+
+matchRule is_active in_scope args rough_args
+ (BuiltinRule { ru_name = name, ru_try = match_fn })
+ = case match_fn args of
+ Just expr -> Just expr
+ Nothing -> Nothing
+
+matchRule is_active in_scope args rough_args
+ (Rule { ru_name = rn, ru_act = act, ru_rough = tpl_tops,
+ ru_bndrs = tpl_vars, ru_args = tpl_args,
+ ru_rhs = rhs })
+ | not (is_active act) = Nothing
+ | ruleCantMatch tpl_tops rough_args = Nothing
+ | otherwise
+ = case matchN in_scope tpl_vars tpl_args args of
+ Nothing -> Nothing
+ Just (tpl_vals, leftovers) -> Just (rule_fn
+ `mkApps` tpl_vals
+ `mkApps` leftovers)
+ where
+ rule_fn = occurAnalyseExpr (mkLams tpl_vars rhs)
+ -- We could do this when putting things into the rulebase, I guess
\end{code}
\begin{code}
-type Matcher result = IdOrTyVarSet -- Template variables
- -> (Subst -> Maybe result) -- Continuation if success
- -> Subst -> Maybe result -- Substitution so far -> result
--- The *SubstEnv* in these Substs apply to the TEMPLATE only
-
--- The *InScopeSet* in these Substs gives a superset of the free vars
--- in the term being matched. This set can get augmented, for example
--- when matching against a lambda:
--- (\x.M) ~ N iff M ~ N x
--- but we must clone x if it's already free in N
+matchN :: InScopeSet
+ -> [Var] -- Template tyvars
+ -> [CoreExpr] -- Template
+ -> [CoreExpr] -- Target; can have more elts than template
+ -> Maybe ([CoreExpr], -- What is substituted for each template var
+ [CoreExpr]) -- Leftover target exprs
+
+matchN in_scope tmpl_vars tmpl_es target_es
+ = do { (subst, leftover_es) <- go init_menv emptySubstEnv tmpl_es target_es
+ ; return (map (lookup_tmpl subst) tmpl_vars, leftover_es) }
+ where
+ init_menv = ME { me_tmpls = mkVarSet tmpl_vars, me_env = init_rn_env }
+ init_rn_env = mkRnEnv2 (extendInScopeSetList in_scope tmpl_vars)
+
+ go menv subst [] es = Just (subst, es)
+ go menv subst ts [] = Nothing -- Fail if too few actual args
+ go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e
+ ; go menv subst1 ts es }
+
+ lookup_tmpl :: (TvSubstEnv, IdSubstEnv) -> Var -> CoreExpr
+ lookup_tmpl (tv_subst, id_subst) tmpl_var
+ | isTyVar tmpl_var = case lookupVarEnv tv_subst tmpl_var of
+ Just ty -> Type ty
+ Nothing -> unbound tmpl_var
+ | otherwise = case lookupVarEnv id_subst tmpl_var of
+ Just e -> e
+ other -> unbound tmpl_var
+
+ unbound var = pprPanic "Template variable unbound in rewrite rule" (ppr var)
+\end{code}
-match :: CoreExpr -- Template
- -> CoreExpr -- Target
- -> Matcher result
-match_fail = Nothing
+ ---------------------------------------------
+ The inner workings of matching
+ ---------------------------------------------
-match (Var v1) e2 tpl_vars kont subst
- = case lookupSubst subst v1 of
- Nothing | v1 `elemVarSet` tpl_vars -> kont (extendSubst subst v1 (DoneEx e2))
- -- v1 is a template variables
+\begin{code}
+-- These two definitions are not the same as in Subst,
+-- but they simple and direct, and purely local to this module
+-- The third, for TvSubstEnv, is the same as in VarEnv, but repeated here
+-- for uniformity with IdSubstEnv
+type SubstEnv = (TvSubstEnv, IdSubstEnv)
+type IdSubstEnv = IdEnv CoreExpr
- | eqExpr (Var v1) e2 -> kont subst
- -- v1 is not a template variable, so it must be a global constant
+emptySubstEnv :: SubstEnv
+emptySubstEnv = (emptyVarEnv, emptyVarEnv)
- Just (DoneEx e2') | eqExpr e2' e2 -> kont subst
- other -> match_fail
+-- At one stage I tried to match even if there are more
+-- template args than real args.
-match (Con c1 es1) (Con c2 es2) tpl_vars kont subst
- | c1 == c2
- = matches es1 es2 tpl_vars kont subst
+-- I now think this is probably a bad idea.
+-- Should the template (map f xs) match (map g)? I think not.
+-- For a start, in general eta expansion wastes work.
+-- SLPJ July 99
-match (App f1 a1) (App f2 a2) tpl_vars kont subst
- = match f1 f2 tpl_vars (match a1 a2 tpl_vars kont) subst
-match (Lam x1 e1) (Lam x2 e2) tpl_vars kont subst
- = bind [x1] [x2] (match e1 e2) tpl_vars kont subst
+match :: MatchEnv
+ -> SubstEnv
+ -> CoreExpr -- Template
+ -> CoreExpr -- Target
+ -> Maybe SubstEnv
--- This rule does eta expansion
--- (\x.M) ~ N iff M ~ N x
--- We must clone the binder in case it's already in scope in N
-match (Lam x1 e1) e2 tpl_vars kont subst
- = match e1 (App e2 (mkVarArg x1')) tpl_vars kont' subst'
- where
- (subst', x1') = substBndr subst x1
- kont' subst = kont (unBindSubst subst x1 x1')
+-- See the notes with Unify.match, which matches types
+-- Everything is very similar for terms
--- Eta expansion the other way
--- M ~ (\y.N) iff \y.M y ~ \y.N
--- iff M y ~ N
--- Remembering that by (A), y can't be free in M, we get this
-match e1 (Lam x2 e2) tpl_vars kont subst
- = match (App e1 (mkVarArg x2)) e2 tpl_vars kont subst
-
-match (Case e1 x1 alts1) (Case e2 x2 alts2) tpl_vars kont subst
- = match e1 e2 tpl_vars case_kont subst
+-- Interesting examples:
+-- Consider matching
+-- \x->f against \f->f
+-- When we meet the lambdas we must remember to rename f to f' in the
+-- second expresion. The RnEnv2 does that.
+--
+-- Consider matching
+-- forall a. \b->b against \a->3
+-- We must rename the \a. Otherwise when we meet the lambdas we
+-- might substitute [a/b] in the template, and then erroneously
+-- succeed in matching what looks like the template variable 'a' against 3.
+
+-- The Var case follows closely what happens in Unify.match
+match menv subst@(tv_subst, id_subst) (Var v1) e2
+ | v1 `elemVarSet` me_tmpls menv
+ = case lookupVarEnv id_subst v1' of
+ Nothing | any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2))
+ -> Nothing -- Occurs check failure
+ -- e.g. match forall a. (\x-> a x) against (\y. y y)
+
+ | otherwise
+ -> Just (tv_subst, extendVarEnv id_subst v1 e2)
+
+ Just e2' | tcEqExprX (nukeRnEnvL rn_env) e2' e2
+ -> Just subst
+
+ other -> Nothing
+
+ | otherwise -- v1 is not a template variable
+ = case e2 of
+ Var v2 | v1' == rnOccR rn_env v2 -> Just subst
+ other -> Nothing
where
- case_kont subst = bind [x1] [x2] (match_alts alts1 (sortLt lt_alt alts2))
- tpl_vars kont subst
-
-match (Type ty1) (Type ty2) tpl_vars kont subst
- = match_ty ty1 ty2 tpl_vars kont subst
-
-match (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2)
- tpl_vars kont subst
- = (match_ty to1 to2 tpl_vars $
- match_ty from1 from2 tpl_vars $
- match e1 e2 tpl_vars kont) subst
-
-
-{- I don't buy this let-rule any more
- The let rule fails on matching
- forall f,x,xs. f (x:xs)
- against
- f (let y = e in (y:[]))
- because we just get x->y, which is bogus.
-
--- This is an interesting rule: we simply ignore lets in the
--- term being matched against! The unfolding inside it is (by assumption)
--- already inside any occurrences of the bound variables, so we'll expand
--- them when we encounter them. Meanwhile, we can't get false matches because
--- (also by assumption) the term being matched has no shadowing.
-match e1 (Let bind e2) tpl_vars kont subst
- = match e1 e2 tpl_vars kont subst
--}
+ rn_env = me_env menv
+ v1' = rnOccL rn_env v1
-- 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,
-- so we don't use it.)
-match e1 (Var v2) tpl_vars kont subst
- = case getIdUnfolding v2 of
- CoreUnfolding form guidance unfolding
- | whnfOrBottom form
- -> match e1 unfolding tpl_vars kont subst
+match menv subst e1 (Var v2)
+ | isCheapUnfolding unfolding
+ = match menv subst e1 (unfoldingTemplate unfolding)
+ where
+ unfolding = idUnfolding v2
- other -> match_fail
+match menv subst (Lit lit1) (Lit lit2)
+ | lit1 == lit2
+ = Just subst
--- We can't cope with lets in the template
+match menv subst (App f1 a1) (App f2 a2)
+ = do { subst' <- match menv subst f1 f2
+ ; match menv subst' a1 a2 }
-match e1 e2 tpl_vars kont subst = match_fail
+match menv subst (Lam x1 e1) (Lam x2 e2)
+ = match menv' subst e1 e2
+ where
+ menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 }
+-- This rule does eta expansion
+-- (\x.M) ~ N iff M ~ N x
+match menv subst (Lam x1 e1) e2
+ = match menv' subst e1 (App e2 (varToCoreExpr new_x))
+ where
+ (rn_env', new_x) = rnBndrL (me_env menv) x1
+ menv' = menv { me_env = rn_env' }
-------------------------------------------
-match_alts [] [] tpl_vars kont subst
- = kont subst
-match_alts ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) tpl_vars kont subst
- | c1 == c2
- = bind vs1 vs2 (match r1 r2) tpl_vars
- (match_alts alts1 alts2 tpl_vars kont)
- subst
-match_alts alts1 alts2 tpl_vars kont subst = match_fail
-
-lt_alt (con1, _, _) (con2, _, _) = con1 < con2
-
-----------------------------------------
-bind :: [CoreBndr] -- Template binders
- -> [CoreBndr] -- Target binders
- -> Matcher result
- -> Matcher result
--- This makes uses of assumption (A) above. For example,
--- this would fail:
--- Template: (\x.y) (y is free)
--- Target : (\y.y) (y is bound)
--- We rename x to y in the template... but then erroneously
--- match y against y. But this can't happen because of (A)
-bind vs1 vs2 matcher tpl_vars kont subst
- = ASSERT( all not_in_subst vs1)
- matcher tpl_vars kont' subst'
+-- Eta expansion the other way
+-- M ~ (\y.N) iff M y ~ N
+match menv subst e1 (Lam x2 e2)
+ = match menv' subst (App e1 (varToCoreExpr new_x)) e2
where
- kont' subst'' = kont (unBindSubstList subst'' vs1 vs2)
- subst' = bindSubstList subst vs1 vs2
-
- -- The unBindSubst relies on no shadowing in the template
- not_in_subst v = not (maybeToBool (lookupSubst subst v))
-
-----------------------------------------
-match_ty ty1 ty2 tpl_vars kont subst
- = case Unify.match ty1 ty2 tpl_vars Just (substEnv subst) of
- Nothing -> match_fail
- Just senv' -> kont (setSubstEnv subst senv')
-
-----------------------------------------
-matches [] [] tpl_vars kont subst
- = kont subst
-matches (e:es) (e':es') tpl_vars kont subst
- = match e e' tpl_vars (matches es es' tpl_vars kont) subst
-matches es es' tpl_vars kont subst
- = match_fail
-
-----------------------------------------
-mkVarArg :: CoreBndr -> CoreArg
-mkVarArg v | isId v = Var v
- | otherwise = Type (mkTyVarTy v)
-\end{code}
+ (rn_env', new_x) = rnBndrR (me_env menv) x2
+ menv' = menv { me_env = rn_env' }
-%************************************************************************
-%* *
-\subsection{Adding a new rule}
-%* *
-%************************************************************************
+match menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
+ = do { subst1 <- match_ty menv subst ty1 ty2
+ ; subst2 <- match menv subst1 e1 e2
+ ; let menv' = menv { me_env = rnBndr2 (me_env menv) x2 x2 }
+ ; match_alts menv' subst2 alts1 alts2 -- Alts are both sorted
+ }
-\begin{code}
-addRule :: Id -> CoreRules -> CoreRule -> CoreRules
+match menv subst (Type ty1) (Type ty2)
+ = match_ty menv subst ty1 ty2
--- Insert the new rule just before a rule that is *less specific*
--- than the new one; or at the end if there isn't such a one.
--- In this way we make sure that when looking up, the first match
--- is the most specific.
---
--- We make no check for rules that unify without one dominating
--- the other. Arguably this would be a bug.
+match menv subst (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2)
+ = do { subst1 <- match_ty menv subst to1 to2
+ ; subst2 <- match_ty menv subst1 from1 from2
+ ; match menv subst2 e1 e2 }
-addRule id (Rules rules rhs_fvs) (Rule str tpl_vars tpl_args rhs)
- = Rules (insert rules) (rhs_fvs `unionVarSet` new_rhs_fvs)
+-- This is an interesting rule: we simply ignore lets in the
+-- term being matched against! The unfolding inside it is (by assumption)
+-- already inside any occurrences of the bound variables, so we'll expand
+-- them when we encounter them.
+match menv subst e1 (Let (NonRec x2 r2) e2)
+ = match menv' subst e1 e2
where
- new_rule = Rule str tpl_vars' tpl_args rhs'
- -- Add occ info to tpl_vars, rhs
+ menv' = menv { me_env = fst (rnBndrR (me_env menv) x2) }
+ -- It's important to do this renaming. For example:
+ -- Matching
+ -- forall f,x,xs. f (x:xs)
+ -- against
+ -- f (let y = e in (y:[]))
+ -- We must not get success with x->y! Instead, we
+ -- need an occurs check.
+
+-- Everything else fails
+match menv subst e1 e2 = Nothing
- (rhs_uds, rhs') = occurAnalyseExpr isLocallyDefined rhs
- (rhs_uds1, tpl_vars') = tagBinders rhs_uds tpl_vars
-
- insert [] = [new_rule]
- insert (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules)
- | otherwise = rule : insert rules
-
- new_is_more_specific rule = maybeToBool (matchRule tpl_var_set rule tpl_args)
+------------------------------------------
+match_alts :: MatchEnv
+ -> SubstEnv
+ -> [CoreAlt] -- Template
+ -> [CoreAlt] -- Target
+ -> Maybe SubstEnv
+match_alts menv subst [] []
+ = return subst
+match_alts menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)
+ | c1 == c2
+ = do { subst1 <- match menv' subst r1 r2
+ ; match_alts menv subst1 alts1 alts2 }
+ where
+ menv' :: MatchEnv
+ menv' = menv { me_env = rnBndrs2 (me_env menv) vs1 vs2 }
- tpl_var_set = mkVarSet tpl_vars'
- -- Actually we should probably include the free vars of tpl_args,
- -- but I can't be bothered
+match_alts menv subst alts1 alts2
+ = Nothing
+\end{code}
- new_rhs_fvs = (exprFreeVars rhs' `minusVarSet` tpl_var_set) `delVarSet` id
- -- Hack alert!
- -- Don't include the Id in its own rhs free-var set.
- -- Otherwise the occurrence analyser makes bindings recursive
- -- that shoudn't be. E.g.
- -- RULE: f (f x y) z ==> f x (f y z)
+Matching Core types: use the matcher in TcType.
+Notice that we treat newtypes as opaque. For example, suppose
+we have a specialised version of a function at a newtype, say
+ newtype T = MkT Int
+We only want to replace (f T) with f', not (f Int).
-addIdSpecialisations :: Id -> [([CoreBndr], [CoreExpr], CoreExpr)] -> Id
-addIdSpecialisations id spec_stuff
- = setIdSpecialisation id new_rules
- where
- rule_name = _PK_ ("SPEC " ++ showSDoc (ppr id))
- new_rules = foldr add (getIdSpecialisation id) spec_stuff
- add (vars, args, rhs) rules = addRule id rules (Rule rule_name vars args rhs)
+\begin{code}
+------------------------------------------
+match_ty menv (tv_subst, id_subst) ty1 ty2
+ = do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2
+ ; return (tv_subst', id_subst) }
\end{code}
%************************************************************************
%* *
-\subsection{Preparing the rule base
+\subsection{Checking a program for failing rule applications}
%* *
%************************************************************************
-\begin{code}
-data ProtoCoreRule
- = ProtoCoreRule
- Bool -- True <=> this rule was defined in this module,
- Id -- What Id is it for
- CoreRule -- The rule itself
-
-
-pprProtoCoreRule (ProtoCoreRule _ fn rule) = pprCoreRule (Just fn) rule
-
-lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr])
-lookupRule in_scope fn args
- = case getIdSpecialisation fn of
- Rules rules _ -> matchRules in_scope rules args
-
-orphanRule :: ProtoCoreRule -> Bool
--- An "orphan rule" is one that is defined in this
--- module, but of ran *imported* function. We need
--- to track these separately when generating the interface file
-orphanRule (ProtoCoreRule local fn _)
- = local && not (isLocallyDefined fn)
-\end{code}
+-----------------------------------------------------
+ Game plan
+-----------------------------------------------------
+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.
-%************************************************************************
-%* *
-\subsection{Getting the rules ready}
-%* *
-%************************************************************************
+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}
-type RuleBase = (IdSet, -- Imported Ids that have rules attached
- IdSet) -- Ids (whether local or imported) mentioned on
- -- LHS of some rule; these should be black listed
+ruleCheckProgram :: CompilerPhase -> String -> [CoreBind] -> SDoc
+-- Report partial matches for rules beginning
+-- with the specified string
+ruleCheckProgram phase rule_pat binds
+ | isEmptyBag results
+ = text "Rule check results: no rule application sites"
+ | otherwise
+ = vcat [text "Rule check results:",
+ line,
+ vcat [ p $$ line | p <- bagToList results ]
+ ]
+ where
+ results = unionManyBags (map (ruleCheckBind (phase, rule_pat)) binds)
+ line = text (replicate 20 '-')
+
+type RuleCheckEnv = (CompilerPhase, String) -- Phase and Pattern
+
+ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
+ -- The Bag returned has one SDoc for each call site found
+ruleCheckBind env (NonRec b r) = ruleCheck env r
+ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (b,r) <- prs]
+
+ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
+ruleCheck env (Var v) = emptyBag
+ruleCheck env (Lit l) = emptyBag
+ruleCheck env (Type ty) = emptyBag
+ruleCheck env (App f a) = ruleCheckApp env (App f a) []
+ruleCheck env (Note n e) = ruleCheck env e
+ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e
+ruleCheck env (Lam b e) = ruleCheck env e
+ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`
+ unionManyBags [ruleCheck env r | (_,_,r) <- as]
+
+ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
+ruleCheckApp env (Var f) as = ruleCheckFun env f as
+ruleCheckApp env other as = ruleCheck env other
+\end{code}
--- The rule Ids and LHS Ids are black-listed; that is, they aren't inlined
--- so that the opportunity to apply the rule isn't lost too soon
+\begin{code}
+ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc
+-- Produce a report for all rules matching the predicate
+-- saying why it doesn't match the specified application
-prepareRuleBase :: [CoreBind] -> [ProtoCoreRule] -> ([CoreBind], RuleBase)
-prepareRuleBase binds rules
- = (map zap_bind binds, (imported_rule_ids, rule_lhs_fvs))
+ruleCheckFun (phase, pat) fn args
+ | null name_match_rules = emptyBag
+ | otherwise = unitBag (ruleAppCheck_help phase fn args name_match_rules)
where
- (rule_ids, rule_lhs_fvs) = foldr add_rule (emptyVarSet, emptyVarSet) rules
- imported_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids
-
- -- rule_fvs is the set of all variables mentioned in rules
- rule_fvs = foldVarSet (unionVarSet . idRuleVars) rule_lhs_fvs rule_ids
-
- -- Attach the rules for each locally-defined Id to that Id.
- -- - This makes the rules easier to look up
- -- - It means that transformation rules and specialisations for
- -- locally defined Ids are handled uniformly
- -- - It keeps alive things that are referred to only from a rule
- -- (the occurrence analyser knows about rules attached to Ids)
- -- - It makes sure that, when we apply a rule, the free vars
- -- of the RHS are more likely to be in scope
- --
- -- The LHS and RHS Ids are marked 'no-discard'.
- -- This means that the binding won't be discarded EVEN if the binding
- -- ends up being trivial (v = w) -- the simplifier would usually just
- -- substitute w for v throughout, but we don't apply the substitution to
- -- the rules (maybe we should?), so this substitution would make the rule
- -- bogus.
- zap_bind (NonRec b r) = NonRec (zap_bndr b) r
- zap_bind (Rec prs) = Rec [(zap_bndr b, r) | (b,r) <- prs]
-
- zap_bndr bndr = case lookupVarSet rule_ids bndr of
- Just bndr' -> setIdNoDiscard bndr'
- Nothing | bndr `elemVarSet` rule_fvs -> setIdNoDiscard bndr
- | otherwise -> bndr
-
-add_rule (ProtoCoreRule _ id rule)
- (rule_id_set, rule_fvs)
- = (rule_id_set `extendVarSet` new_id,
- rule_fvs `unionVarSet` extendVarSet lhs_fvs id)
+ name_match_rules = filter match (idCoreRules fn)
+ match rule = pat `isPrefixOf` unpackFS (ruleName rule)
+
+ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
+ruleAppCheck_help phase fn args rules
+ = -- The rules match the pattern, so we want to print something
+ vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
+ vcat (map check_rule rules)]
where
- new_id = case lookupVarSet rule_id_set id of
- Just id' -> addRuleToId id' rule
- Nothing -> addRuleToId id rule
- lhs_fvs = ruleSomeLhsFreeVars isId rule
- -- Find *all* the free Ids of the LHS, not just
- -- locally defined ones!!
-
-addRuleToId id rule = setIdSpecialisation id (addRule id (getIdSpecialisation id) rule)
+ n_args = length args
+ i_args = args `zip` [1::Int ..]
+ rough_args = map roughTopName args
+
+ check_rule rule = rule_herald rule <> colon <+> rule_info rule
+
+ rule_herald (BuiltinRule { ru_name = name })
+ = ptext SLIT("Builtin rule") <+> doubleQuotes (ftext name)
+ rule_herald (Rule { ru_name = name })
+ = ptext SLIT("Rule") <+> doubleQuotes (ftext name)
+
+ rule_info rule
+ | Just _ <- matchRule noBlackList emptyInScopeSet args rough_args rule
+ = text "matches (which is very peculiar!)"
+
+ rule_info (BuiltinRule {}) = text "does not match"
+
+ rule_info (Rule { ru_name = name, ru_act = act,
+ ru_bndrs = rule_bndrs, ru_args = rule_args})
+ | not (isActive phase act) = text "active only in later phase"
+ | n_args < n_rule_args = text "too few arguments"
+ | n_mismatches == n_rule_args = text "no arguments match"
+ | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not"
+ | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"
+ where
+ n_rule_args = length rule_args
+ n_mismatches = length mismatches
+ mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
+ not (isJust (match_fn rule_arg arg))]
+
+ lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars
+ match_fn rule_arg arg = match menv emptySubstEnv rule_arg arg
+ where
+ in_scope = lhs_fvs `unionVarSet` exprFreeVars arg
+ menv = ME { me_env = mkRnEnv2 (mkInScopeSet in_scope)
+ , me_tmpls = mkVarSet rule_bndrs }
\end{code}
projects / ghc-hetmet.git / blobdiff