X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FRules.lhs;h=758d60db04de959e3d30a6a9046265acc04191a6;hb=1ca40c2037a0e973dd73d98cd20313ecdbfeb6fc;hp=6fc35a515b03d99eb8001d37a9ba4dcb93fa3ec4;hpb=29723ae3cdf941a9647d2cd67e5aa15bab8f4e22;p=ghc-hetmet.git diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index 6fc35a5..758d60d 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -19,23 +19,22 @@ 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 CoreUtils ( tcEqExprX, exprType ) import PprCore ( pprRules ) -import Type ( TvSubstEnv ) +import Type ( Type, TvSubstEnv ) import Coercion ( coercionKind ) import TcType ( tcSplitTyConApp_maybe ) import CoreTidy ( tidyRules ) -import Id ( Id, idUnfolding, isLocalId, isGlobalId, idName, +import Id ( Id, idUnfolding, isLocalId, isGlobalId, idName, idType, idSpecialisation, idCoreRules, setIdSpecialisation ) import IdInfo ( SpecInfo( SpecInfo ) ) import Var ( Var ) import VarEnv import VarSet -import Name ( Name, NamedThing(..), nameOccName ) +import Name ( Name, NamedThing(..) ) import NameEnv import Unify ( ruleMatchTyX, MatchEnv(..) ) import BasicTypes ( Activation, CompilerPhase, isActive ) @@ -91,7 +90,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] @@ -196,10 +195,27 @@ pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs) %* * %************************************************************************ +Note [Extra args in rule matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we find a matching rule, we return (Just (rule, rhs)), +but the rule firing has only consumed as many of the input args +as the ruleArity says. It's up to the caller to keep track +of any left-over args. E.g. if you call + lookupRule ... f [e1, e2, e3] +and it returns Just (r, rhs), where r has ruleArity 2 +then the real rewrite is + f e1 e2 e3 ==> rhs e3 + +You might think it'd be cleaner for lookupRule to deal with the +leftover arguments, by applying 'rhs' to them, but the main call +in the Simplifier works better as it is. Reason: the 'args' passed +to lookupRule are the result of a lazy substitution + \begin{code} lookupRule :: (Activation -> Bool) -> InScopeSet -> RuleBase -- Imported rules -> Id -> [CoreExpr] -> Maybe (CoreRule, CoreExpr) +-- See Note [Extra argsin rule matching] lookupRule is_active in_scope rule_base fn args = matchRules is_active in_scope fn args rules where @@ -348,19 +364,25 @@ matchN in_scope tmpl_vars tmpl_es target_es Just e -> e 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 - Taret: f (x+1) -This should succeed, because the template variable 'x' has nothing to do with -the 'x' in the target. + 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' +To achive this, we use rnBndrL to rename the template variables if +necessary; the renamed ones are the tmpl_vars' --------------------------------------------- @@ -476,17 +498,37 @@ match menv subst e1 (Var v2) -- potentially inefficient, because of the calls to substExpr, -- but I don't think it'll happen much in pracice. +{- Cases to think about + (let x=y+1 in \x. (x,x)) + --> let x=y+1 in (\x1. (x1,x1)) + (\x. let x = y+1 in (x,x)) + --> let x1 = y+1 in (\x. (x1,x1) + (let x=y+1 in (x,x), let x=y-1 in (x,x)) + --> let x=y+1 in let x1=y-1 in ((x,x),(x1,x1)) + +Watch out! + (let x=y+1 in let z=x+1 in (z,z) + --> matches (p,p) but watch out that the use of + x on z's rhs is OK! +I'm removing the cloning because that makes the above case +fail, because the inner let looks as if it has locally-bound vars -} + match menv subst@(tv_subst, id_subst, binds) e1 (Let bind e2) - | not (any locally_bound bind_fvs) + | 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 - rhss = rhssOfBind bind bind_fvs = varSetElems (bindFreeVars bind) locally_bound x = inRnEnvR rn_env x + freshly_bound x = not (x `rnInScope` rn_env) + bind' = bind + e2' = e2 + rn_env' = extendRnInScopeList rn_env bndrs +{- (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) @@ -495,6 +537,7 @@ match menv subst@(tv_subst, id_subst, binds) e1 (Let bind 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 @@ -588,10 +631,21 @@ match_var menv subst@(tv_subst, id_subst, binds) v1 e2 -> Nothing -- Occurs check failure -- 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 e2' | tcEqExprX (nukeRnEnvL rn_env) e2' e2 + | otherwise -- No renaming to do on e2, because no free var + -- of e2 is in the rnEnvR of the envt + -- However, we must match the *types*; e.g. + -- forall (c::Char->Int) (x::Char). + -- f (c x) = "RULE FIRED" + -- We must only match on args that have the right type + -- It's actually quite difficult to come up with an example that shows + -- you need type matching, esp since matching is left-to-right, so type + -- args get matched first. But it's possible (e.g. simplrun008) and + -- this is the Right Thing to do + -> do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst (idType v1') (exprType e2) + -- c.f. match_ty below + ; return (tv_subst', extendVarEnv id_subst v1' e2, binds) } + + Just e1' | tcEqExprX (nukeRnEnvL rn_env) e1' e2 -> Just subst | otherwise @@ -639,6 +693,11 @@ We only want to replace (f T) with f', not (f Int). \begin{code} ------------------------------------------ +match_ty :: MatchEnv + -> SubstEnv + -> Type -- Template + -> Type -- Target + -> Maybe SubstEnv match_ty menv (tv_subst, id_subst, binds) ty1 ty2 = do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2 ; return (tv_subst', id_subst, binds) }