X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fspecialise%2FRules.lhs;h=39a9f054c56f6678a621917f08d9f2a1432b029e;hp=4d743140ea66e63bc1242acdc80c9cb58fac3e23;hb=960a5edb6ac87c7d85e36f4b70be8da0175819f7;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index 4d74314..39a9f05 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -4,13 +4,33 @@ \section[CoreRules]{Transformation rules} \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + +-- | Functions for collecting together and applying rewrite rules to a module. +-- The 'CoreRule' datatype itself is declared elsewhere. module Rules ( - RuleBase, emptyRuleBase, mkRuleBase, extendRuleBaseList, - unionRuleBase, pprRuleBase, ruleCheckProgram, - + -- * RuleBase + RuleBase, + + -- ** Constructing + emptyRuleBase, mkRuleBase, extendRuleBaseList, + unionRuleBase, pprRuleBase, + + -- ** Checking rule applications + ruleCheckProgram, + + -- ** Manipulating 'SpecInfo' rules mkSpecInfo, extendSpecInfo, addSpecInfo, - rulesOfBinds, addIdSpecialisations, - + addIdSpecialisations, + + -- * Misc. CoreRule helpers + rulesOfBinds, getRules, pprRulesForUser, + lookupRule, mkLocalRule, roughTopNames ) where @@ -18,33 +38,30 @@ module Rules ( import CoreSyn -- All of it import OccurAnal ( occurAnalyseExpr ) -import CoreFVs ( exprFreeVars, exprsFreeVars, rulesRhsFreeVars ) -import CoreUnfold ( isCheapUnfolding, unfoldingTemplate ) -import CoreUtils ( tcEqExprX ) +import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars ) +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, - idSpecialisation, idCoreRules, setIdSpecialisation ) +import Id 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 ) +import VarEnv import VarSet -import Name ( Name, NamedThing(..), nameOccName ) +import Name ( Name, NamedThing(..) ) import NameEnv import Unify ( ruleMatchTyX, MatchEnv(..) ) -import BasicTypes ( Activation, CompilerPhase, isActive ) +import BasicTypes ( Activation ) +import StaticFlags ( opt_PprStyle_Debug ) import Outputable import FastString -import Maybes ( isJust, orElse ) +import Maybes +import OrdList import Bag -import Util ( singleton ) -import List ( isPrefixOf ) +import Util +import Data.List \end{code} @@ -85,23 +102,29 @@ where pi' :: Lift Int# is the specialised version of pi. \begin{code} mkLocalRule :: RuleName -> Activation -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule --- Used to make CoreRule for an Id defined in this module +-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being +-- compiled. See also 'CoreSyn.CoreRule' 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] +-- ^ Find the \"top\" free names of several expressions. +-- Such names are either: +-- +-- 1. The function finally being applied to in an application chain +-- (if that name is a GlobalId: see "Var#globalvslocal"), or +-- +-- 2. The 'TyCon' if the expression is a 'Type' +-- +-- This is used for the fast-match-check for rules; +-- if the top names don't match, the rest can't roughTopNames args = map roughTopName args roughTopName :: CoreExpr -> Maybe Name --- Find the "top" free name of an expression --- a) the function in an App chain (if a GlobalId) --- b) the TyCon in a type --- This is used for the fast-match-check for rules; --- if the top names don't match, the rest can't roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of Just (tc,_) -> Just (getName tc) Nothing -> Nothing @@ -111,16 +134,39 @@ roughTopName (Var f) | isGlobalId f = Just (idName f) roughTopName other = Nothing ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool --- (ruleCantMatch tpl actual) returns True only if 'actual' --- definitely can't match 'tpl' by instantiating 'tpl'. +-- ^ @ruleCantMatch tpl actual@ returns True only if @actual@ +-- definitely can't match @tpl@ by instantiating @tpl@. -- It's only a one-way match; unlike instance matching we --- don't consider unification +-- don't consider unification. +-- +-- Notice that [_$_] +-- @ruleCantMatch [Nothing] [Just n2] = False@ +-- Reason: a template variable can be instantiated by a constant +-- Also: +-- @ruleCantMatch [Just n1] [Nothing] = False@ +-- Reason: a local variable @v@ in the actuals might [_$_] + ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as -ruleCantMatch (Just n1 : ts) (Nothing : as) = True ruleCantMatch (t : ts) (a : as) = ruleCantMatch ts as ruleCantMatch ts as = False \end{code} +\begin{code} +pprRulesForUser :: [CoreRule] -> SDoc +-- (a) tidy the rules +-- (b) sort them into order based on the rule name +-- (c) suppress uniques (unless -dppr-debug is on) +-- This combination makes the output stable so we can use in testing +-- It's here rather than in PprCore because it calls tidyRules +pprRulesForUser rules + = withPprStyle defaultUserStyle $ + pprRules $ + sortLe le_rule $ + tidyRules emptyTidyEnv rules + where + le_rule r1 r2 = ru_name r1 <= ru_name r2 +\end{code} + %************************************************************************ %* * @@ -129,12 +175,14 @@ ruleCantMatch ts as = False %************************************************************************ \begin{code} +-- | Make a 'SpecInfo' containing a number of 'CoreRule's, suitable +-- for putting into an 'IdInfo' mkSpecInfo :: [CoreRule] -> SpecInfo -mkSpecInfo rules = SpecInfo rules (rulesRhsFreeVars rules) +mkSpecInfo rules = SpecInfo rules (rulesFreeVars rules) extendSpecInfo :: SpecInfo -> [CoreRule] -> SpecInfo extendSpecInfo (SpecInfo rs1 fvs1) rs2 - = SpecInfo (rs2 ++ rs1) (rulesRhsFreeVars rs2 `unionVarSet` fvs1) + = SpecInfo (rs2 ++ rs1) (rulesFreeVars rs2 `unionVarSet` fvs1) addSpecInfo :: SpecInfo -> SpecInfo -> SpecInfo addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2) @@ -145,8 +193,21 @@ addIdSpecialisations id rules = setIdSpecialisation id $ extendSpecInfo (idSpecialisation id) rules +-- | Gather all the rules for locally bound identifiers from the supplied bindings rulesOfBinds :: [CoreBind] -> [CoreRule] rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds + +getRules :: RuleBase -> Id -> [CoreRule] + -- The rules for an Id come from two places: + -- (a) the ones it is born with (idCoreRules fn) + -- (b) rules added in subsequent modules (extra_rules) + -- PrimOps, for example, are born with a bunch of rules under (a) +getRules rule_base fn + | isLocalId fn = idCoreRules fn + | otherwise = WARN( not (isPrimOpId fn) && notNull (idCoreRules fn), + ppr fn <+> ppr (idCoreRules fn) ) + idCoreRules fn ++ (lookupNameEnv rule_base (idName fn) `orElse` []) + -- Only PrimOpIds have rules inside themselves, and perhaps more besides \end{code} @@ -157,8 +218,8 @@ rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds %************************************************************************ \begin{code} +-- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules type RuleBase = NameEnv [CoreRule] - -- Maps (the name of) an Id to its rules -- The rules are are unordered; -- we sort out any overlaps on lookup @@ -190,30 +251,38 @@ 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} +-- | The main rule matching function. Attempts to apply all (active) +-- supplied rules to this instance of an application in a given +-- context, returning the rule applied and the resulting expression if +-- successful. lookupRule :: (Activation -> Bool) -> InScopeSet - -> RuleBase -- Imported rules - -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr) -lookupRule is_active in_scope rule_base fn args - = matchRules is_active in_scope fn args rules - where - -- The rules for an Id come from two places: - -- (a) the ones it is born with (idCoreRules fn) - -- (b) rules added in subsequent modules (extra_rules) - -- PrimOps, for example, are born with a bunch of rules under (a) - rules = extra_rules ++ idCoreRules fn - extra_rules | isLocalId fn = [] - | otherwise = lookupNameEnv rule_base (idName fn) `orElse` [] + -> Id -> [CoreExpr] + -> [CoreRule] -> Maybe (CoreRule, CoreExpr) -matchRules :: (Activation -> Bool) -> InScopeSet - -> Id -> [CoreExpr] - -> [CoreRule] -> Maybe (RuleName, CoreExpr) +-- See Note [Extra args in rule matching] -- See comments on matchRule -matchRules is_active in_scope fn args rules - = case go [] rules of +lookupRule is_active in_scope fn args rules + = -- 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 @@ -221,7 +290,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) @@ -232,16 +303,18 @@ findBest :: (Id, [CoreExpr]) findBest target (rule,ans) [] = (rule,ans) findBest target (rule1,ans1) ((rule2,ans2):prs) | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs - | rule2 `isMoreSpecific` rule1 = findBest target (rule1,ans1) prs -#ifdef DEBUG - | otherwise = pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" - (vcat [ptext SLIT("Expression to match:") <+> ppr fn <+> sep (map ppr args), - ptext SLIT("Rule 1:") <+> ppr rule1, - ptext SLIT("Rule 2:") <+> ppr rule2]) $ + | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs + | debugIsOn = let pp_rule rule + | opt_PprStyle_Debug = ppr rule + | otherwise = doubleQuotes (ftext (ru_name rule)) + in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" + (vcat [if opt_PprStyle_Debug then + ptext (sLit "Expression to match:") <+> ppr fn <+> sep (map ppr args) + else empty, + ptext (sLit "Rule 1:") <+> pp_rule rule1, + ptext (sLit "Rule 2:") <+> pp_rule rule2]) $ findBest target (rule1,ans1) prs -#else | otherwise = findBest target (rule1,ans1) prs -#endif where (fn,args) = target @@ -299,47 +372,70 @@ 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 (tpl_vals, leftovers) -> Just (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 \end{code} \begin{code} -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 +-- For a given match template and context, find bindings to wrap around +-- the entire result and what should be substituted for each template variable. +-- Fail if there are two few actual arguments from the target to match the template +matchN :: InScopeSet -- ^ In-scope variables + -> [Var] -- ^ Match template type variables + -> [CoreExpr] -- ^ Match template + -> [CoreExpr] -- ^ Target; can have more elements than the template + -> Maybe ([CoreBind], + [CoreExpr]) 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) } + = 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') } 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 :: 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 + 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 @@ -348,13 +444,18 @@ matchN in_scope tmpl_vars tmpl_es target_es \begin{code} -- These two definitions are not the same as in Subst, -- but they simple and direct, and purely local to this module --- The third, for TvSubstEnv, is the same as in VarEnv, but repeated here --- for uniformity with IdSubstEnv -type SubstEnv = (TvSubstEnv, IdSubstEnv) -type IdSubstEnv = IdEnv CoreExpr +-- +-- * The domain of the TvSubstEnv and IdSubstEnv are the template +-- variables passed into the match. +-- +-- * The (OrdList CoreBind) in a SubstEnv are the bindings floated out +-- from nested matches; see the Let case of match, below +-- +type SubstEnv = (TvSubstEnv, IdSubstEnv, OrdList CoreBind) +type IdSubstEnv = IdEnv CoreExpr emptySubstEnv :: SubstEnv -emptySubstEnv = (emptyVarEnv, emptyVarEnv) +emptySubstEnv = (emptyVarEnv, emptyVarEnv, nilOL) -- At one stage I tried to match even if there are more @@ -388,28 +489,19 @@ match :: MatchEnv -- 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 e2) - - Just e2' | tcEqExprX (nukeRnEnvL rn_env) e2' e2 - -> Just subst +match menv subst (Var v1) e2 + | Just subst <- match_var menv subst v1 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 +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 @@ -419,7 +511,85 @@ match menv subst e1 (Var v2) | isCheapUnfolding unfolding = match menv subst e1 (unfoldingTemplate unfolding) where - unfolding = idUnfolding v2 + rn_env = me_env menv + 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. + +{- 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) + | 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) + 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) + (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 @@ -436,6 +606,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 @@ -453,36 +626,95 @@ match menv subst e1 (Lam x2 e2) 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 } + ; let menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 } ; match_alts menv' subst2 alts1 alts2 -- Alts are both sorted } 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) - = do { subst1 <- match_ty menv subst to1 to2 - ; subst2 <- match_ty menv subst1 from1 from2 - ; match menv subst2 e1 e2 } +match menv subst (Cast e1 co1) (Cast e2 co2) + = do { subst1 <- match_ty menv subst co1 co2 + ; match menv subst1 e1 e2 } +{- 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 --- them when we encounter them. -match menv subst e1 (Let (NonRec x2 r2) e2) - = match menv' subst e1 e2 +-- them when we encounter them. This gives a chance of matching +-- forall x,y. f (g (x,y)) +-- against +-- f (let v = (a,b) in g v) + +match menv subst e1 (Let bind e2) + = match (menv { me_env = rn_env' }) subst e1 e2 where - menv' = menv { me_env = fst (rnBndrR (me_env menv) x2) } - -- It's important to do this renaming. For example: + (rn_env', _bndrs') = mapAccumL rnBndrR (me_env menv) (bindersOf bind) + -- It's important to do this renaming, so that the bndrs + -- are brought into the local scope. 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. + -- 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 + -> SubstEnv + -> Var -- Template + -> CoreExpr -- Target + -> Maybe SubstEnv +match_var menv subst@(tv_subst, id_subst, binds) 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 -- No renaming to do on e2, because no free var + -- of e2 is in the rnEnvR of the envt + -- Note [Matching variable types] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- 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 + -> Nothing + + | otherwise -- v1 is not a template variable; check for an exact match with e2 + = 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 + -- If the template is + -- forall x. f x (\x -> x) = ... + -- Then the x inside the lambda isn't the + -- template x, so we must rename first! + ------------------------------------------ match_alts :: MatchEnv @@ -512,12 +744,53 @@ We only want to replace (f T) with f', not (f Int). \begin{code} ------------------------------------------ -match_ty menv (tv_subst, id_subst) ty1 ty2 +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) } + ; return (tv_subst', id_subst, binds) } \end{code} +Note [Lookup in-scope] +~~~~~~~~~~~~~~~~~~~~~~ +Consider this example + foo :: Int -> Maybe Int -> Int + foo 0 (Just n) = n + foo m (Just n) = foo (m-n) (Just n) + +SpecConstr sees this fragment: + + case w_smT of wild_Xf [Just A] { + Data.Maybe.Nothing -> lvl_smf; + Data.Maybe.Just n_acT [Just S(L)] -> + case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] -> + \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf + }}; + +and correctly generates the rule + + RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int# + sc_snn :: GHC.Prim.Int#} + \$wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr)) + = \$s\$wfoo_sno y_amr sc_snn ;] + +BUT we must ensure that this rule matches in the original function! +Note that the call to \$wfoo is + \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf + +During matching we expand wild_Xf to (Just n_acT). But then we must also +expand n_acT to (I# y_amr). And we can only do that if we look up n_acT +in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding +at all. + +That is why the 'lookupRnInScope' call in the (Var v2) case of 'match' +is so important. + + %************************************************************************ %* * \subsection{Checking a program for failing rule applications} @@ -531,16 +804,15 @@ match_ty menv (tv_subst, id_subst) ty1 ty2 We want to know what sites have rules that could have fired but didn't. This pass runs over the tree (without changing it) and reports such. -NB: we assume that this follows a run of the simplifier, so every Id -occurrence (including occurrences of imported Ids) is decorated with -all its (active) rules. No need to construct a rule base or anything -like that. - \begin{code} -ruleCheckProgram :: CompilerPhase -> String -> [CoreBind] -> SDoc --- Report partial matches for rules beginning --- with the specified string -ruleCheckProgram phase rule_pat binds +-- | Report partial matches for rules beginning with the specified +-- string for the purposes of error reporting +ruleCheckProgram :: (Activation -> Bool) -- ^ Rule activation test + -> String -- ^ Rule pattern + -> RuleBase -- ^ Database of rules + -> [CoreBind] -- ^ Bindings to check in + -> SDoc -- ^ Resulting check message +ruleCheckProgram is_active rule_pat rule_base binds | isEmptyBag results = text "Rule check results: no rule application sites" | otherwise @@ -549,10 +821,14 @@ ruleCheckProgram phase rule_pat binds vcat [ p $$ line | p <- bagToList results ] ] where - results = unionManyBags (map (ruleCheckBind (phase, rule_pat)) binds) + results = unionManyBags (map (ruleCheckBind (RuleCheckEnv is_active rule_pat rule_base)) binds) line = text (replicate 20 '-') -type RuleCheckEnv = (CompilerPhase, String) -- Phase and Pattern +data RuleCheckEnv = RuleCheckEnv { + rc_is_active :: Activation -> Bool, + rc_pattern :: String, + rc_rule_base :: RuleBase +} ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc -- The Bag returned has one SDoc for each call site found @@ -565,6 +841,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` @@ -580,15 +857,15 @@ ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc -- Produce a report for all rules matching the predicate -- saying why it doesn't match the specified application -ruleCheckFun (phase, pat) fn args +ruleCheckFun env fn args | null name_match_rules = emptyBag - | otherwise = unitBag (ruleAppCheck_help phase fn args name_match_rules) + | otherwise = unitBag (ruleAppCheck_help (rc_is_active env) fn args name_match_rules) where - name_match_rules = filter match (idCoreRules fn) - match rule = pat `isPrefixOf` unpackFS (ruleName rule) + name_match_rules = filter match (getRules (rc_rule_base env) fn) + match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule) -ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc -ruleAppCheck_help phase fn args rules +ruleAppCheck_help :: (Activation -> Bool) -> Id -> [CoreExpr] -> [CoreRule] -> SDoc +ruleAppCheck_help is_active fn args rules = -- The rules match the pattern, so we want to print something vcat [text "Expression:" <+> ppr (mkApps (Var fn) args), vcat (map check_rule rules)] @@ -600,9 +877,9 @@ ruleAppCheck_help phase fn args rules check_rule rule = rule_herald rule <> colon <+> rule_info rule rule_herald (BuiltinRule { ru_name = name }) - = ptext SLIT("Builtin rule") <+> doubleQuotes (ftext name) + = ptext (sLit "Builtin rule") <+> doubleQuotes (ftext name) rule_herald (Rule { ru_name = name }) - = ptext SLIT("Rule") <+> doubleQuotes (ftext name) + = ptext (sLit "Rule") <+> doubleQuotes (ftext name) rule_info rule | Just _ <- matchRule noBlackList emptyInScopeSet args rough_args rule @@ -612,7 +889,7 @@ ruleAppCheck_help phase fn args rules rule_info (Rule { ru_name = name, ru_act = act, ru_bndrs = rule_bndrs, ru_args = rule_args}) - | not (isActive phase act) = text "active only in later phase" + | not (is_active 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 rule as a whole does not"