#include "HsVersions.h"
import CoreSyn -- All of it
+import CoreSubst ( substExpr, mkSubst )
import OccurAnal ( occurAnalyseExpr )
import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesRhsFreeVars )
import CoreUnfold ( isCheapUnfolding, unfoldingTemplate )
import CoreUtils ( tcEqExprX )
import PprCore ( pprRules )
import Type ( TvSubstEnv )
+import Coercion ( coercionKind )
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,
- rnInScope, extendRnInScopeList, lookupRnInScope )
+import VarEnv
import VarSet
import Name ( Name, NamedThing(..), nameOccName )
import NameEnv
import BasicTypes ( Activation, CompilerPhase, isActive )
import Outputable
import FastString
-import Maybes ( isJust, orElse )
+import Maybes
import OrdList
import Bag
-import Util ( singleton, mapAccumL )
-import List ( isPrefixOf )
+import Util
+import List hiding( mapAccumL ) -- Also defined in Util
\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]
\begin{code}
lookupRule :: (Activation -> Bool) -> InScopeSet
-> RuleBase -- Imported rules
- -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
+ -> Id -> [CoreExpr] -> Maybe (CoreRule, CoreExpr)
lookupRule is_active in_scope rule_base fn args
= matchRules is_active in_scope fn args rules
where
matchRules :: (Activation -> Bool) -> InScopeSet
-> Id -> [CoreExpr]
- -> [CoreRule] -> Maybe (RuleName, CoreExpr)
+ -> [CoreRule] -> Maybe (CoreRule, CoreExpr)
-- See comments on matchRule
matchRules is_active in_scope fn args rules
- = case go [] rules of
+ = -- pprTrace "matchRules" (ppr fn <+> ppr rules) $
+ case go [] rules of
[] -> Nothing
- (m:ms) -> Just (case findBest (fn,args) m ms of
- (rule, ans) -> (ru_name rule, ans))
+ (m:ms) -> Just (findBest (fn,args) m ms)
where
rough_args = map roughTopName args
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
+ Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$
+ -- ppr [(arg_id, unfoldingTemplate unf) | Var arg_id <- args, let unf = idUnfolding arg_id, isCheapUnfolding unf] )
+ go ms rs
findBest :: (Id, [CoreExpr])
-> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)
| ruleCantMatch tpl_tops rough_args = Nothing
| otherwise
= case matchN in_scope tpl_vars tpl_args args of
- Nothing -> Nothing
- Just (binds, tpl_vals, leftovers) -> Just (mkLets binds $
- rule_fn
- `mkApps` tpl_vals
- `mkApps` leftovers)
+ Nothing -> Nothing
+ Just (binds, tpl_vals) -> Just (mkLets binds $
+ rule_fn `mkApps` tpl_vals)
where
rule_fn = occurAnalyseExpr (mkLams tpl_vars rhs)
-- We could do this when putting things into the rulebase, I guess
-> [CoreExpr] -- Template
-> [CoreExpr] -- Target; can have more elts than template
-> Maybe ([CoreBind], -- Bindings to wrap around the entire result
- [CoreExpr], -- What is substituted for each template var
- [CoreExpr]) -- Leftover target exprs
+ [CoreExpr]) -- What is substituted for each template var
matchN in_scope tmpl_vars tmpl_es target_es
- = do { ((tv_subst, id_subst, binds), leftover_es)
+ = do { (tv_subst, id_subst, binds)
<- go init_menv emptySubstEnv tmpl_es target_es
; return (fromOL binds,
- map (lookup_tmpl tv_subst id_subst) tmpl_vars,
- leftover_es) }
+ map (lookup_tmpl tv_subst id_subst) tmpl_vars') }
where
- init_menv = ME { me_tmpls = mkVarSet tmpl_vars, me_env = init_rn_env }
- init_rn_env = mkRnEnv2 (extendInScopeSetList in_scope tmpl_vars)
+ (init_rn_env, tmpl_vars') = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars
+ -- See Note [Template binders]
+
+ init_menv = ME { me_tmpls = mkVarSet tmpl_vars', me_env = init_rn_env }
- go menv subst [] es = Just (subst, es)
+ go menv subst [] es = Just subst
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
+ 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
+ Nothing -> unbound tmpl_var'
+ | otherwise = case lookupVarEnv id_subst tmpl_var' of
Just e -> e
- other -> unbound tmpl_var
+ 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
+ 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'
+
---------------------------------------------
The inner workings of matching
| 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,
-- so we don't use it.)
match menv subst e1 (Var v2)
- | not (inRnEnvR rn_env v2),
- -- If v2 is in the RnEnvR, then it's locally bound and can't
- -- have an unfolding. We must make this check because if it
- -- is locally bound we must not look it up in the in-scope set
- -- E.g. (\x->x) where x is already in scope
- isCheapUnfolding unfolding
+ | isCheapUnfolding unfolding
= match menv subst e1 (unfoldingTemplate unfolding)
where
rn_env = me_env menv
- unfolding = idUnfolding (lookupRnInScope rn_env v2)
+ unfolding = idUnfolding (lookupRnInScope rn_env (rnOccR rn_env v2))
-- Notice that we look up v2 in the in-scope set
-- 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
+-- f (let { w=R } in g E))
+-- Then we'd like the rule to match, to generate
+-- let { w=R } in (\x. <rhs>) E
+-- In effect, we want to float the let-binding outward, to enable
+-- the match to happen. This is the WHOLE REASON for accumulating
+-- bindings in the SubstEnv
+--
+-- 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.
+
+match menv subst@(tv_subst, id_subst, binds) e1 (Let bind e2)
+ | not (any locally_bound bind_fvs)
+ = match (menv { me_env = rn_env' })
+ (tv_subst, id_subst, binds `snocOL` bind')
+ e1 e2'
+ where
+ rn_env = me_env menv
+ bndrs = bindersOf bind
+ rhss = rhssOfBind bind
+ bind_fvs = varSetElems (bindFreeVars bind)
+ locally_bound x = inRnEnvR rn_env x
+ (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
-- This rule does eta expansion
-- (\x.M) ~ N iff M ~ N x
+-- It's important that this is *after* the let rule,
+-- so that (\x.M) ~ (let y = e in \y.N)
+-- does the let thing, and then gets the lam/lam rule above
match menv subst (Lam x1 e1) e2
= match menv' subst e1 (App e2 (varToCoreExpr new_x))
where
match menv subst (Type ty1) (Type ty2)
= match_ty menv subst ty1 ty2
-match menv subst (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2)
+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 }
--- Matching a let-expression. Consider
--- RULE forall x. f (g x) = <rhs>
--- and target expression
--- f (let { w=R } in g E))
--- Then we'd like the rule to match, to generate
--- let { w=R } in (\x. <rhs>) E
--- In effect, we want to float the let-binding outward, to enable
--- the match to happen. This is the WHOLE REASON for accumulating
--- bindings in the SubstEnv
---
--- 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
--- (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.
-
-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
- where
- rn_env = me_env menv
- bndrs = bindersOf bind
- bind_fvs = varSetElems (bindFreeVars bind)
- freshly_bound x = not (x `rnInScope` rn_env)
- locally_bound x = inRnEnvR rn_env x
- rn_env' = extendRnInScopeList rn_env bndrs
-
+{- REMOVING OLD CODE: I think that the above handling for let is
+ better than the stuff here, which looks
+ pretty suspicious to me. SLPJ Sept 06
-- 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
-- We must not get success with x->y! So we record that y is
-- locally bound (with rnBndrR), and proceed. The Var case
-- will fail when trying to bind x->y
- --
+-}
-- Everything else fails
-match menv subst e1 e2 = Nothing
+match menv subst e1 e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr e1) $$ (text "e2:" <+> ppr e2)) $
+ Nothing
------------------------------------------
match_var :: MatchEnv
-- 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 (tv_subst, extendVarEnv id_subst v1' e2, binds)
- Just e2' | tcEqExprX (nukeRnEnvL rn_env) e2' e2
+ Just e1' | tcEqExprX (nukeRnEnvL rn_env) e1' e2
-> Just subst
| otherwise
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 (Cast e co) = 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`
projects / ghc-hetmet.git / blobdiff