\begin{code}
module Rules (
- RuleBase, prepareRuleBase, lookupRule,
- addIdSpecialisations,
+ RuleBase, prepareLocalRuleBase, prepareOrphanRuleBase,
+ unionRuleBase, lookupRule, addRule, addIdSpecialisations,
ProtoCoreRule(..), pprProtoCoreRule,
- orphanRule
+ localRule, orphanRule
) where
#include "HsVersions.h"
import OccurAnal ( occurAnalyseExpr, tagBinders, UsageDetails )
import BinderInfo ( markMany )
import CoreFVs ( exprFreeVars, idRuleVars, ruleSomeLhsFreeVars )
-import CoreUnfold ( Unfolding(..) )
-import CoreUtils ( whnfOrBottom, eqExpr )
+import CoreUnfold ( isCheapUnfolding, unfoldingTemplate )
+import CoreUtils ( eqExpr, cheapEqExpr )
import PprCore ( pprCoreRule )
import Subst ( Subst, InScopeSet, substBndr, lookupSubst, extendSubst,
- mkSubst, substEnv, setSubstEnv,
- unBindSubst, bindSubstList, unBindSubstList,
+ mkSubst, substEnv, setSubstEnv, emptySubst, isInScope,
+ unBindSubst, bindSubstList, unBindSubstList, substInScope
)
-import Id ( Id, getIdUnfolding,
- getIdSpecialisation, setIdSpecialisation,
+import Id ( Id, idUnfolding, zapLamIdInfo,
+ idSpecialisation, setIdSpecialisation,
setIdNoDiscard, maybeModifyIdInfo, modifyIdInfo
)
-import IdInfo ( zapLamIdInfo, setSpecInfo, specInfo )
+import IdInfo ( setSpecInfo, specInfo )
import Name ( Name, isLocallyDefined )
import Var ( isTyVar, isId )
import VarSet
%************************************************************************
\begin{code}
-matchRules :: InScopeSet -> [CoreRule] -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr])
+matchRules :: InScopeSet -> [CoreRule] -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
-- See comments on matchRule
matchRules in_scope [] args = Nothing
matchRules in_scope (rule:rules) args
Nothing -> matchRules in_scope rules args
-matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr])
+matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (RuleName, 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
+-- A1. No top-level variable is bound in the target
+-- A2. No template variable is bound in the target
+-- A3. No lambda bound template variable is free in any subexpression of the target
+--
+-- To see why A1 is necessary, consider matching
+-- \x->f against \f->f
+-- When we meet the lambdas we substitute [f/x] in the template (a no-op),
+-- and then erroneously succeed in matching f against f.
+--
+-- To see why A2 is needed consider matching
+-- forall a. \b->b against \a->3
+-- When we meet the lambdas we substitute [a/b] in the template, and then
+-- erroneously succeed in matching what looks like the template variable 'a' against 3.
+--
+-- A3 is needed to validate the rule that says
+-- (\x->E) matches F
+-- if
+-- (\x->E) matches (\x->F x)
+
+
+matchRule in_scope rule@(BuiltinRule match_fn) args = match_fn args
-matchRule in_scope (Rule rn tpl_vars tpl_args rhs) args
- = go tpl_args args (mkSubst in_scope emptySubstEnv)
+matchRule in_scope rule@(Rule rn tpl_vars tpl_args rhs) args
+ = go tpl_args args emptySubst
+ -- We used to use the in_scope set, but I don't think that's necessary
+ -- After all, the result is going to be simplified again with that in_scope set
where
tpl_var_set = mkVarSet tpl_vars
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)
+ go [] [] subst = Just (rn, app_match subst (mkLams tpl_vars rhs) tpl_vars)
+ go [] args subst = Just (rn, app_match subst (mkLams tpl_vars rhs) tpl_vars `mkApps` args)
-- One tiresome way to terminate: check for excess unmatched
-- template arguments
- go tpl_args [] subst
+ go tpl_args [] subst = Nothing -- Failure
+
+
+ -----------------------
+ app_match subst fn vs = foldl go fn vs
+ where
+ senv = substEnv subst
+ go fn v = case lookupSubstEnv senv v of
+ Just (DoneEx ex) -> fn `App` ex
+ Just (DoneTy ty) -> fn `App` Type ty
+ -- Substitution should bind them all!
+
+
+ -----------------------
+{- The code below tries to match even if there are more
+ template args than real args.
+
+ 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
+
= case eta_complete tpl_args (mkVarSet leftovers) of
Just leftovers' -> Just (rn, mkLams done (mkLams leftovers' rhs),
mk_result_args subst done)
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
+ | otherwise = zapLamIdInfo bndr
\end{code}
\begin{code}
-type Matcher result = IdOrTyVarSet -- Template variables
+type Matcher result = VarSet -- 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
+-- The *InScopeSet* in these Substs gives variables bound so far in the
+-- target term. So when matching forall a. (\x. a x) against (\y. y y)
+-- while processing the body of the lambdas, the in-scope set will be {y}.
+-- That lets us do the occurs-check when matching 'a' against 'y'
match :: CoreExpr -- Template
-> CoreExpr -- Target
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
+ Nothing | v1 `elemVarSet` tpl_vars -- v1 is a template variable
+ -> if (any (`isInScope` subst) (varSetElems (exprFreeVars e2))) then
+ match_fail -- Occurs check failure
+ -- e.g. match forall a. (\x-> a x) against (\y. y y)
+ else
+ kont (extendSubst subst v1 (DoneEx e2))
+
| eqExpr (Var v1) e2 -> kont subst
-- v1 is not a template variable, so it must be a global constant
other -> match_fail
-match (Con c1 es1) (Con c2 es2) tpl_vars kont subst
- | c1 == c2
- = matches es1 es2 tpl_vars kont subst
+match (Lit lit1) (Lit lit2) tpl_vars kont subst
+ | lit1 == lit2
+ = kont subst
match (App f1 a1) (App f2 a2) tpl_vars kont subst
= match f1 f2 tpl_vars (match a1 a2 tpl_vars kont) subst
-- 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
+-- See assumption A3
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')
+ = bind [x1] [x1] (match e1 (App e2 (mkVarArg x1))) tpl_vars kont subst
-- 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
+ = bind [new_id] [x2] (match (App e1 (mkVarArg new_id)) e2) tpl_vars kont subst
+ where
+ new_id = uniqAway (substInScope subst) x2
+ -- This uniqAway is actually needed. Here's the example:
+ -- rule: foldr (mapFB (:) f) [] = mapList
+ -- target: foldr (\x. mapFB k f x) []
+ -- where
+ -- k = \x. mapFB ... x
+ -- The first \x is ok, but when we inline k, hoping it might
+ -- match (:) we find a second \x.
match (Case e1 x1 alts1) (Case e2 x2 alts2) tpl_vars kont subst
= match e1 e2 tpl_vars case_kont subst
-- (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
+ | isCheapUnfolding unfolding
+ = match e1 (unfoldingTemplate unfolding) tpl_vars kont subst
+ where
+ unfolding = idUnfolding v2
- other -> match_fail
-- We can't cope with lets in the template
-- 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)
+ = WARN( not (all not_in_subst vs1), bug_msg )
matcher tpl_vars kont' subst'
where
kont' subst'' = kont (unBindSubstList subst'' vs1 vs2)
-- The unBindSubst relies on no shadowing in the template
not_in_subst v = not (maybeToBool (lookupSubst subst v))
+ bug_msg = sep [ppr vs1, ppr vs2]
----------------------------------------
match_ty ty1 ty2 tpl_vars kont subst
-- We make no check for rules that unify without one dominating
-- the other. Arguably this would be a bug.
+addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _)
+ = Rules (rule:rules) rhs_fvs
+ -- Put it at the start for lack of anything better
+
addRule id (Rules rules rhs_fvs) (Rule str tpl_vars tpl_args rhs)
= Rules (insert rules) (rhs_fvs `unionVarSet` new_rhs_fvs)
where
= setIdSpecialisation id new_rules
where
rule_name = _PK_ ("SPEC " ++ showSDoc (ppr id))
- new_rules = foldr add (getIdSpecialisation id) spec_stuff
+ new_rules = foldr add (idSpecialisation id) spec_stuff
add (vars, args, rhs) rules = addRule id rules (Rule rule_name vars args rhs)
\end{code}
pprProtoCoreRule (ProtoCoreRule _ fn rule) = pprCoreRule (Just fn) rule
-lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr])
+lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
lookupRule in_scope fn args
- = case getIdSpecialisation fn of
+ = case idSpecialisation fn of
Rules rules _ -> matchRules in_scope rules args
+localRule :: ProtoCoreRule -> Bool
+localRule (ProtoCoreRule local _ _) = local
+
orphanRule :: ProtoCoreRule -> Bool
-- An "orphan rule" is one that is defined in this
--- module, but of ran *imported* function. We need
+-- module, but for an *imported* function. We need
-- to track these separately when generating the interface file
orphanRule (ProtoCoreRule local fn _)
= local && not (isLocallyDefined fn)
IdSet) -- Ids (whether local or imported) mentioned on
-- LHS of some rule; these should be black listed
+unionRuleBase (rule_ids1, black_ids1) (rule_ids2, black_ids2)
+ = (plusUFM_C merge_rules rule_ids1 rule_ids2,
+ unionVarSet black_ids1 black_ids2)
+ where
+ merge_rules id1 id2 = let rules1 = idSpecialisation id1
+ rules2 = idSpecialisation id2
+ new_rules = foldl (addRule id1) rules1 (rulesRules rules2)
+ in
+ setIdSpecialisation id1 new_rules
+
+-- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
+-- It attaches those rules that are for local Ids to their binders, and
+-- returns the remainder attached to Ids in an IdSet. It also returns
+-- Ids mentioned on LHS of some rule; these should be blacklisted.
+
-- 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
-prepareRuleBase :: [CoreBind] -> [ProtoCoreRule] -> ([CoreBind], RuleBase)
-prepareRuleBase binds rules
- = (map zap_bind binds, (imported_rule_ids, rule_lhs_fvs))
+prepareLocalRuleBase :: [CoreBind] -> [ProtoCoreRule] -> ([CoreBind], RuleBase)
+prepareLocalRuleBase binds local_rules
+ = (map zap_bind binds, (imported_id_rule_ids, rule_lhs_fvs))
where
- (rule_ids, rule_lhs_fvs) = foldr add_rule (emptyVarSet, emptyVarSet) rules
- imported_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids
+ (rule_ids, rule_lhs_fvs) = foldr add_rule (emptyVarSet, emptyVarSet) local_rules
+ imported_id_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids
- -- rule_fvs is the set of all variables mentioned in rules
+ -- rule_fvs is the set of all variables mentioned in this module's rules
rule_fvs = foldVarSet (unionVarSet . idRuleVars) rule_lhs_fvs rule_ids
-- Attach the rules for each locally-defined Id to that Id.
-- Find *all* the free Ids of the LHS, not just
-- locally defined ones!!
-addRuleToId id rule = setIdSpecialisation id (addRule id (getIdSpecialisation id) rule)
-\end{code}
+addRuleToId id rule = setIdSpecialisation id (addRule id (idSpecialisation id) rule)
+-- prepareOrphanRuleBase does exactly the same as prepareLocalRuleBase, except that
+-- it assumes that none of the rules can be attached to local Ids.
+
+prepareOrphanRuleBase :: [ProtoCoreRule] -> RuleBase
+prepareOrphanRuleBase imported_rules
+ = foldr add_rule (emptyVarSet, emptyVarSet) imported_rules
+\end{code}