X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FRules.lhs;h=35b44ab98c94541cad3ea11341fee445ff9cf698;hb=beade0a18125941847f87c97f81c1e0a49f01416;hp=4f62115f9c3d6b63ba071104a4f951d7ef5a8775;hpb=818c42cb4310f7543b117ae93426c17acbe1b2c9;p=ghc-hetmet.git diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index 4f62115..35b44ab 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -33,7 +33,7 @@ import Id ( Id, idUnfolding, isLocalId, isGlobalId, idName, import IdInfo ( SpecInfo( SpecInfo ) ) import Var ( Var ) import VarEnv ( IdEnv, InScopeSet, emptyTidyEnv, - emptyInScopeSet, mkInScopeSet, extendInScopeSetList, + emptyInScopeSet, mkInScopeSet, emptyVarEnv, lookupVarEnv, extendVarEnv, nukeRnEnvL, mkRnEnv2, rnOccR, rnOccL, inRnEnvR, rnBndrR, rnBndr2, rnBndrL, rnBndrs2, @@ -45,11 +45,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 ) -import List ( isPrefixOf ) +import Util +import List hiding( mapAccumL ) -- Also defined in Util \end{code} @@ -203,7 +203,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 @@ -217,13 +217,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 @@ -231,7 +231,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) @@ -309,11 +311,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 @@ -325,36 +325,47 @@ 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) \end{code} +Note [Template binders] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following match: + Template: forall x. f x + Taret: f (x+1) +This should succeed, because the template variable 'x' has nothing to do with +the 'x' in the target. + +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 @@ -417,18 +428,14 @@ match menv subst (Var v1) e2 -- (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) -- Matching a let-expression. Consider -- RULE forall x. f (g x) = @@ -538,7 +545,8 @@ match menv subst e1 (Let bind e2) -} -- 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 @@ -554,7 +562,7 @@ 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 subst