\begin{code}
module Rules (
RuleBase, emptyRuleBase,
- extendRuleBase, extendRuleBaseList,
- ruleBaseIds, getLocalRules,
- pprRuleBase, ruleCheckProgram,
+ extendRuleBaseList,
+ ruleBaseIds, pprRuleBase, ruleCheckProgram,
lookupRule, addRule, addIdSpecialisations
) where
import CoreSyn -- All of it
import OccurAnal ( occurAnalyseRule )
-import CoreFVs ( exprFreeVars, ruleRhsFreeVars )
+import CoreFVs ( exprFreeVars, exprsFreeVars, ruleRhsFreeVars )
import CoreUnfold ( isCheapUnfolding, unfoldingTemplate )
-import CoreUtils ( eqExpr )
+import CoreUtils ( tcEqExprX )
import CoreTidy ( pprTidyIdRules )
-import Subst ( Subst, InScopeSet, mkInScopeSet, lookupSubst, extendSubst,
- substEnv, setSubstEnv, emptySubst, isInScope, emptyInScopeSet,
- bindSubstList, unBindSubstList, substInScope, uniqAway
- )
-import Id ( Id, idIsFrom, idUnfolding, idSpecialisation, setIdSpecialisation )
-import Var ( isId )
+import Subst ( IdSubstEnv, SubstResult(..) )
+import Id ( Id, idUnfolding, idSpecialisation, setIdSpecialisation )
+import Var ( Var )
import VarSet
import VarEnv
-import TcType ( mkTyVarTy )
-import qualified TcType ( match )
+import TcType ( TvSubstEnv )
+import Unify ( matchTyX, MatchEnv(..) )
import BasicTypes ( Activation, CompilerPhase, isActive )
-import Module ( Module )
import Outputable
import FastString
-import Maybe ( isJust, isNothing, fromMaybe )
-import Util ( sortLt )
+import Maybe ( isJust, fromMaybe )
+import Util ( sortLe )
import Bag
-import List ( isPrefixOf, partition )
+import List ( isPrefixOf )
\end{code}
--
-- Any 'surplus' arguments in the input are simply put on the end
-- of the output.
---
--- ASSUMPTION (A):
--- 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 is_active in_scope rule@(BuiltinRule name match_fn) args
= case match_fn args of
| not (is_active act)
= Nothing
| otherwise
- = 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
-
- -----------------------
- -- 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, 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 = 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 -- Failure
- where
- (done, leftovers) = partition (\v -> isJust (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
-
-
-zapOccInfo bndr | isTyVar bndr = bndr
- | otherwise = zapLamIdInfo bndr
--}
+ = case matchN in_scope tpl_vars tpl_args args of
+ Just (tpl_vals, leftovers) -> Just (rn, mkLams tpl_vars rhs `mkApps` tpl_vals `mkApps` leftovers)
+ Nothing -> Nothing
\end{code}
\begin{code}
-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 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
+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 (DoneEx e) -> e
+ other -> unbound tmpl_var
+
+ unbound var = pprPanic "Template variable unbound in rewrite rule" (ppr var)
+
+emptySubstEnv :: (TvSubstEnv, IdSubstEnv)
+emptySubstEnv = (emptyVarEnv, emptyVarEnv)
+
+
+-- At one stage I tried 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
+
+
+match :: MatchEnv
+ -> (TvSubstEnv, IdSubstEnv)
+ -> CoreExpr -- Template
-> CoreExpr -- Target
- -> Matcher result
-
-match_fail = Nothing
-
-match (Var v1) e2 tpl_vars kont subst
- = case lookupSubst subst v1 of
- 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))
+ -> Maybe (TvSubstEnv, IdSubstEnv)
+-- See the notes with Unify.match, which matches types
+-- Everything is very similar for terms
- | eqExpr (Var v1) e2 -> kont subst
- -- v1 is not a template variable, so it must be a global constant
-
- Just (DoneEx e2') | eqExpr e2' e2 -> 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 (DoneEx e2))
+
+ Just (DoneEx 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
+ rn_env = me_env menv
+ v1' = rnOccL rn_env v1
- other -> match_fail
+-- 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 menv subst e1 (Var v2)
+ | isCheapUnfolding unfolding
+ = match menv subst e1 (unfoldingTemplate unfolding)
+ where
+ unfolding = idUnfolding v2
-match (Lit lit1) (Lit lit2) tpl_vars kont subst
+match menv subst (Lit lit1) (Lit lit2)
| lit1 == lit2
- = kont subst
+ = Just subst
-match (App f1 a1) (App f2 a2) tpl_vars kont subst
- = match f1 f2 tpl_vars (match a1 a2 tpl_vars kont) subst
+match menv subst (App f1 a1) (App f2 a2)
+ = do { subst' <- match menv subst f1 f2
+ ; match menv subst' a1 a2 }
-match (Lam x1 e1) (Lam x2 e2) tpl_vars kont subst
- = bind [x1] [x2] (match e1 e2) tpl_vars kont subst
+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
--- See assumption A3
-match (Lam x1 e1) e2 tpl_vars kont subst
- = bind [x1] [x1] (match e1 (App e2 (mkVarArg x1))) tpl_vars kont subst
+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' }
-- 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
- = bind [new_id] [x2] (match (App e1 (mkVarArg new_id)) e2) tpl_vars kont subst
+-- M ~ (\y.N) iff M y ~ N
+match menv subst e1 (Lam x2 e2)
+ = match menv' subst (App e1 (varToCoreExpr new_x)) e2
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
- 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
+ (rn_env', new_x) = rnBndrR (me_env menv) x2
+ menv' = menv { me_env = rn_env' }
-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
+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 (sortLe le_alt alts1) (sortLe le_alt alts2)
+ }
+match menv subst (Type ty1) (Type ty2)
+ = match_ty menv subst ty1 ty2
-{- 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.
+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 }
-- 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
--}
-
--- 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
- | isCheapUnfolding unfolding
- = match e1 (unfoldingTemplate unfolding) tpl_vars kont subst
+-- them when we encounter them.
+match menv subst e1 (Let (NonRec x2 r2) e2)
+ = match menv' subst e1 e2
where
- unfolding = idUnfolding v2
-
-
--- We can't cope with lets in the template
-
-match e1 e2 tpl_vars kont subst = match_fail
-
+ 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
------------------------------------------
-match_alts [] [] tpl_vars kont subst
- = kont subst
-match_alts ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) tpl_vars kont subst
+match_alts :: MatchEnv
+ -> (TvSubstEnv, IdSubstEnv)
+ -> [CoreAlt] -- Template
+ -> [CoreAlt] -- Target
+ -> Maybe (TvSubstEnv, IdSubstEnv)
+match_alts menv subst [] []
+ = return subst
+match_alts menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)
| 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
- = WARN( not (all not_in_subst vs1), bug_msg )
- matcher tpl_vars kont' subst'
+ = do { subst1 <- match menv' subst r1 r2
+ ; match_alts menv subst1 alts1 alts2 }
where
- kont' subst'' = kont (unBindSubstList subst'' vs1 vs2)
- subst' = bindSubstList subst vs1 vs2
+ menv' :: MatchEnv
+ menv' = menv { me_env = rnBndrs2 (me_env menv) vs1 vs2 }
- -- The unBindSubst relies on no shadowing in the template
- not_in_subst v = isNothing (lookupSubst subst v)
- bug_msg = sep [ppr vs1, ppr vs2]
+match_alts menv subst alts1 alts2
+ = Nothing
-----------------------------------------
-mkVarArg :: CoreBndr -> CoreArg
-mkVarArg v | isId v = Var v
- | otherwise = Type (mkTyVarTy v)
+le_alt (con1, _, _) (con2, _, _) = con1 <= con2
\end{code}
Matching Core types: use the matcher in TcType.
We only want to replace (f T) with f', not (f Int).
\begin{code}
-----------------------------------------
-match_ty ty1 ty2 tpl_vars kont subst
- = TcType.match ty1 ty2 tpl_vars kont' (substEnv subst)
- where
- kont' senv = kont (setSubstEnv subst senv)
+------------------------------------------
+match_ty menv (tv_subst, id_subst) ty1 ty2
+ = do { tv_subst' <- Unify.matchTyX menv tv_subst ty1 ty2
+ ; return (tv_subst', id_subst) }
\end{code}
-
%************************************************************************
%* *
\subsection{Adding a new rule}
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]
+-- gaw 2004
+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
| 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 the rule as a whole does not"
+ | 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
mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
not (isJust (match_fn rule_arg arg))]
- bndr_set = mkVarSet rule_bndrs
- match_fn rule_arg arg = match rule_arg arg bndr_set (\s -> Just ()) emptySubst
+ 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}
ruleBaseIds (RuleBase ids) = ids
emptyRuleBase = RuleBase emptyVarSet
-extendRuleBaseList :: RuleBase -> [(Id,CoreRule)] -> RuleBase
+extendRuleBaseList :: RuleBase -> [IdCoreRule] -> RuleBase
extendRuleBaseList rule_base new_guys
= foldl extendRuleBase rule_base new_guys
-extendRuleBase :: RuleBase -> (Id,CoreRule) -> RuleBase
-extendRuleBase (RuleBase rule_ids) (id, rule)
+extendRuleBase :: RuleBase -> IdCoreRule -> RuleBase
+extendRuleBase (RuleBase rule_ids) (IdCoreRule id _ rule)
= RuleBase (extendVarSet rule_ids new_id)
where
new_id = setIdSpecialisation id (addRule id old_rules rule)
-- in which case it may have rules in its belly already. Seems
-- dreadfully hackoid.
-getLocalRules :: Module -> RuleBase -> (IdSet, -- Ids with local rules
- RuleBase) -- Non-local rules
--- Get the rules for locally-defined Ids out of the RuleBase
--- If we miss any rules for Ids defined here, then we end up
--- giving the local decl a new Unique (because the in-scope-set is (hackily) the
--- same as the non-local-rule-id set, so the Id looks as if it's in scope
--- and hence should be cloned), and now the binding for the class method
--- doesn't have the same Unique as the one in the Class and the tc-env
--- Example: class Foo a where
--- op :: a -> a
--- {-# RULES "op" op x = x #-}
---
--- NB we can't use isLocalId, because isLocalId isn't true of class methods.
-getLocalRules this_mod (RuleBase ids)
- = (mkVarSet local_ids, RuleBase (mkVarSet imp_ids))
- where
- (local_ids, imp_ids) = partition (idIsFrom this_mod) (varSetElems ids)
-
pprRuleBase :: RuleBase -> SDoc
pprRuleBase (RuleBase rules) = vcat [ pprTidyIdRules id | id <- varSetElems rules ]
\end{code}
projects / ghc-hetmet.git / blobdiff