X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fspecialise%2FRules.lhs;h=4b7e926e423b79f61afb3b62da12eb1c356939cc;hp=c7edd8f31534eff64634e53d08d32f29b7f8c065;hb=eb2bf7ad9f967861da2e19ff71a80428c7c2df28;hpb=969baa167e4afa382b2558a3648d57862c4401eb diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index c7edd8f..4b7e926 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -19,24 +19,21 @@ module Rules ( #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 @@ -44,11 +41,11 @@ import Unify ( ruleMatchTyX, MatchEnv(..) ) 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} @@ -94,7 +91,7 @@ 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 } + ru_local = True } -------------- roughTopNames :: [CoreExpr] -> [Maybe Name] @@ -202,7 +199,7 @@ pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs) \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 @@ -216,13 +213,13 @@ lookupRule is_active in_scope rule_base fn args 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 @@ -230,7 +227,9 @@ matchRules is_active in_scope fn args rules 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) @@ -308,11 +307,9 @@ matchRule is_active in_scope args rough_args | 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 @@ -324,36 +321,53 @@ matchN :: InScopeSet -> [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 @@ -411,23 +425,82 @@ match menv subst (Var v1) e2 | 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) = +-- 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. ) 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 @@ -444,6 +517,9 @@ match menv subst (Lam x1 e1) (Lam x2 e2) -- 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 @@ -468,43 +544,16 @@ match menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) 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) = --- 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. ) 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 @@ -526,10 +575,11 @@ match menv subst e1 (Let bind e2) -- 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 @@ -545,9 +595,9 @@ match_var menv subst@(tv_subst, id_subst, binds) v1 e2 -- 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 @@ -684,6 +734,7 @@ 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 (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`