X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FRules.lhs;h=e66e048eff7ca3c4c0e8da0f1f128884821132b8;hb=36d22a1cb608e8572776ab6d402fd0c1a9287dc5;hp=f1d29bdf6744ebf0bbb3b8381369fb42f8a1849e;hpb=69e14f75a4b031e489b7774914e5a176409cea78;p=ghc-hetmet.git diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index f1d29bd..e66e048 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -5,43 +5,34 @@ \begin{code} module Rules ( - RuleBase, prepareRuleBase, lookupRule, - addIdSpecialisations, - ProtoCoreRule(..), pprProtoCoreRule, orphanRule + RuleBase, emptyRuleBase, + extendRuleBaseList, + ruleBaseIds, pprRuleBase, ruleCheckProgram, + + lookupRule, addRule, addRules, addIdSpecialisations ) where #include "HsVersions.h" import CoreSyn -- All of it -import OccurAnal ( occurAnalyseExpr, tagBinders, UsageDetails ) -import BinderInfo ( markMany ) -import CoreFVs ( exprFreeVars, idRuleVars, ruleSomeLhsFreeVars ) -import CoreUnfold ( Unfolding(..) ) -import CoreUtils ( whnfOrBottom, eqExpr ) -import PprCore ( pprCoreRule ) -import Subst ( Subst, InScopeSet, substBndr, lookupSubst, extendSubst, - mkSubst, substEnv, setSubstEnv, - unBindSubst, bindSubstList, unBindSubstList, - ) -import Id ( Id, getIdUnfolding, - getIdSpecialisation, setIdSpecialisation, - setIdNoDiscard, maybeModifyIdInfo, modifyIdInfo - ) -import IdInfo ( zapLamIdInfo, setSpecInfo, specInfo ) -import Name ( Name, isLocallyDefined ) -import Var ( isTyVar, isId ) +import OccurAnal ( occurAnalyseRule ) +import CoreFVs ( exprFreeVars, exprsFreeVars, ruleRhsFreeVars ) +import CoreUnfold ( isCheapUnfolding, unfoldingTemplate ) +import CoreUtils ( tcEqExprX ) +import Type ( Type ) +import CoreTidy ( pprTidyIdRules ) +import Id ( Id, idUnfolding, isLocalId, idSpecialisation, setIdSpecialisation ) +import Var ( Var ) import VarSet import VarEnv -import Type ( mkTyVarTy, getTyVar_maybe ) -import qualified Unify ( match ) -import CmdLineOpts ( opt_D_dump_simpl, opt_D_verbose_core2core ) +import Unify ( tcMatchTyX, MatchEnv(..) ) +import BasicTypes ( Activation, CompilerPhase, isActive ) -import UniqFM -import ErrUtils ( dumpIfSet ) import Outputable -import Maybes ( maybeToBool ) -import List ( partition ) -import Util ( sortLt ) +import FastString +import Maybe ( isJust, fromMaybe ) +import Bag +import List ( isPrefixOf ) \end{code} @@ -87,20 +78,24 @@ where pi' :: Lift Int# is the specialised version of pi. %************************************************************************ \begin{code} -matchRules :: InScopeSet -> [CoreRule] -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr]) +matchRules :: (Activation -> Bool) -> InScopeSet + -> [CoreRule] -> [CoreExpr] -> Maybe (RuleName, CoreExpr) -- See comments on matchRule -matchRules in_scope [] args = Nothing -matchRules in_scope (rule:rules) args - = case matchRule in_scope rule args of +matchRules is_active in_scope [] args = Nothing +matchRules is_active in_scope (rule:rules) args + = case matchRule is_active in_scope rule args of Just result -> Just result - Nothing -> matchRules in_scope rules args + Nothing -> matchRules is_active in_scope rules args +noBlackList :: Activation -> Bool +noBlackList act = False -- Nothing is black listed -matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr]) +matchRule :: (Activation -> Bool) -> InScopeSet + -> CoreRule -> [CoreExpr] -> Maybe (RuleName, CoreExpr) --- If (matchRule rule args) returns Just (name,rhs,args') +-- If (matchRule rule args) returns Just (name,rhs) -- then (f args) matches the rule, and the corresponding --- rewritten RHS is (rhs args'). +-- rewritten RHS is rhs -- -- The bndrs and rhs is occurrence-analysed -- @@ -115,230 +110,236 @@ matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (FAST_STRING, CoreExp -- map (f.g) x) -- rhs -- -- Then the call: matchRule the_rule [e1,map e2 e3] --- = Just ("map/map", \f,g,x -> rhs, [e1,e2,e3]) +-- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3) -- -- Any 'surplus' arguments in the input are simply put on the end -- of the output. --- --- ASSUMPTION (A): --- No variable free in the template is bound in the target - -matchRule in_scope (Rule rn tpl_vars tpl_args rhs) args - = go tpl_args args (mkSubst in_scope emptySubstEnv) - where - tpl_var_set = mkVarSet tpl_vars - - ----------------------- - -- Do the business - go (tpl_arg:tpl_args) (arg:args) subst = match tpl_arg arg tpl_var_set (go tpl_args args) subst - - -- Two easy ways to terminate - go [] [] subst = Just (rn, mkLams tpl_vars rhs, mk_result_args subst tpl_vars) - go [] args subst = Just (rn, mkLams tpl_vars rhs, mk_result_args subst tpl_vars ++ args) - - -- One tiresome way to terminate: check for excess unmatched - -- template arguments - go tpl_args [] subst - = case eta_complete tpl_args (mkVarSet leftovers) of - Just leftovers' -> Just (rn, mkLams done (mkLams leftovers' rhs), - mk_result_args subst done) - Nothing -> Nothing -- Failure - where - (done, leftovers) = partition (\v -> maybeToBool (lookupSubstEnv subst_env v)) - (map zapOccInfo tpl_vars) - -- Zap the occ info - subst_env = substEnv subst - - ----------------------- - eta_complete [] vars = ASSERT( isEmptyVarSet vars ) - Just [] - eta_complete (Type ty:tpl_args) vars - = case getTyVar_maybe ty of - Just tv | tv `elemVarSet` vars - -> case eta_complete tpl_args (vars `delVarSet` tv) of - Just vars' -> Just (tv:vars') - Nothing -> Nothing - other -> Nothing - - eta_complete (Var v:tpl_args) vars - | v `elemVarSet` vars - = case eta_complete tpl_args (vars `delVarSet` v) of - Just vars' -> Just (v:vars') - Nothing -> Nothing - - eta_complete other vars = Nothing - - ----------------------- - mk_result_args subst vs = map go vs - where - senv = substEnv subst - go v = case lookupSubstEnv senv v of - Just (DoneEx ex) -> ex - Just (DoneTy ty) -> Type ty - -- Substitution should bind them all! - -zapOccInfo bndr | isTyVar bndr = bndr - | otherwise = maybeModifyIdInfo zapLamIdInfo bndr + +matchRule is_active in_scope rule@(BuiltinRule name match_fn) args + = case match_fn args of + Just expr -> Just (name,expr) + Nothing -> Nothing + +matchRule is_active in_scope rule@(Rule rn act tpl_vars tpl_args rhs) args + | not (is_active act) + = Nothing + | otherwise + = case matchN in_scope tpl_vars tpl_args args of + Just (tpl_vals, leftovers) -> Just (rn, mkLams tpl_vars rhs `mkApps` tpl_vals `mkApps` leftovers) + Nothing -> Nothing \end{code} \begin{code} -type Matcher result = IdOrTyVarSet -- Template variables - -> (Subst -> Maybe result) -- Continuation if success - -> Subst -> Maybe result -- Substitution so far -> result --- The *SubstEnv* in these Substs apply to the TEMPLATE only - --- The *InScopeSet* in these Substs gives a superset of the free vars --- in the term being matched. This set can get augmented, for example --- when matching against a lambda: --- (\x.M) ~ N iff M ~ N x --- but we must clone x if it's already free in N +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 + +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) } + where + init_menv = ME { me_tmpls = mkVarSet tmpl_vars, me_env = init_rn_env } + init_rn_env = mkRnEnv2 (extendInScopeSetList in_scope tmpl_vars) + + go menv subst [] es = Just (subst, es) + 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 + Just ty -> Type ty + Nothing -> unbound tmpl_var + | otherwise = case lookupVarEnv id_subst tmpl_var of + Just e -> e + other -> unbound tmpl_var + + unbound var = pprPanic "Template variable unbound in rewrite rule" (ppr var) +\end{code} -match :: CoreExpr -- Template - -> CoreExpr -- Target - -> Matcher result -match_fail = Nothing + --------------------------------------------- + The inner workings of matching + --------------------------------------------- -match (Var v1) e2 tpl_vars kont subst - = case lookupSubst subst v1 of - Nothing | v1 `elemVarSet` tpl_vars -> kont (extendSubst subst v1 (DoneEx e2)) - -- v1 is a template variables +\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 +type TvSubstEnv = TyVarEnv Type - | eqExpr (Var v1) e2 -> kont subst - -- v1 is not a template variable, so it must be a global constant +emptySubstEnv :: SubstEnv +emptySubstEnv = (emptyVarEnv, emptyVarEnv) - Just (DoneEx e2') | eqExpr e2' e2 -> kont subst - other -> match_fail +-- At one stage I tried to match even if there are more +-- template args than real args. -match (Con c1 es1) (Con c2 es2) tpl_vars kont subst - | c1 == c2 - = matches es1 es2 tpl_vars kont subst +-- I now think this is probably a bad idea. +-- Should the template (map f xs) match (map g)? I think not. +-- For a start, in general eta expansion wastes work. +-- SLPJ July 99 + + +match :: MatchEnv + -> SubstEnv + -> CoreExpr -- Template + -> CoreExpr -- Target + -> Maybe SubstEnv + +-- See the notes with Unify.match, which matches types +-- Everything is very similar for terms + +-- Interesting examples: +-- Consider matching +-- \x->f against \f->f +-- When we meet the lambdas we must remember to rename f to f' in the +-- second expresion. The RnEnv2 does that. +-- +-- Consider matching +-- forall a. \b->b against \a->3 +-- We must rename the \a. Otherwise when we meet the lambdas we +-- might substitute [a/b] in the template, and then erroneously +-- 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 + + 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 + +-- 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) + | isCheapUnfolding unfolding + = match menv subst e1 (unfoldingTemplate unfolding) + where + unfolding = idUnfolding v2 -match (App f1 a1) (App f2 a2) tpl_vars kont subst - = match f1 f2 tpl_vars (match a1 a2 tpl_vars kont) subst +match menv subst (Lit lit1) (Lit lit2) + | lit1 == lit2 + = Just subst -match (Lam x1 e1) (Lam x2 e2) tpl_vars kont subst - = bind [x1] [x2] (match e1 e2) tpl_vars kont subst +match menv subst (App f1 a1) (App f2 a2) + = do { subst' <- match menv subst f1 f2 + ; match menv subst' a1 a2 } + +match menv subst (Lam x1 e1) (Lam x2 e2) + = match menv' subst e1 e2 + where + menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 } -- This rule does eta expansion -- (\x.M) ~ N iff M ~ N x --- We must clone the binder in case it's already in scope in N -match (Lam x1 e1) e2 tpl_vars kont subst - = match e1 (App e2 (mkVarArg x1')) tpl_vars kont' subst' +match menv subst (Lam x1 e1) e2 + = match menv' subst e1 (App e2 (varToCoreExpr new_x)) where - (subst', x1') = substBndr subst x1 - kont' subst = kont (unBindSubst subst x1 x1') + (rn_env', new_x) = rnBndrL (me_env menv) x1 + menv' = menv { me_env = rn_env' } -- Eta expansion the other way --- M ~ (\y.N) iff \y.M y ~ \y.N --- iff M y ~ N --- Remembering that by (A), y can't be free in M, we get this -match e1 (Lam x2 e2) tpl_vars kont subst - = match (App e1 (mkVarArg x2)) e2 tpl_vars kont subst - -match (Case e1 x1 alts1) (Case e2 x2 alts2) tpl_vars kont subst - = match e1 e2 tpl_vars case_kont subst +-- M ~ (\y.N) iff M y ~ N +match menv subst e1 (Lam x2 e2) + = match menv' subst (App e1 (varToCoreExpr new_x)) e2 where - case_kont subst = bind [x1] [x2] (match_alts alts1 (sortLt lt_alt alts2)) - tpl_vars kont subst - -match (Type ty1) (Type ty2) tpl_vars kont subst - = match_ty ty1 ty2 tpl_vars kont subst + (rn_env', new_x) = rnBndrR (me_env menv) x2 + menv' = menv { me_env = rn_env' } -match (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2) - tpl_vars kont subst - = (match_ty to1 to2 tpl_vars $ - match_ty from1 from2 tpl_vars $ - match e1 e2 tpl_vars kont) subst +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 } + ; match_alts menv' subst2 alts1 alts2 -- Alts are both sorted + } +match menv subst (Type ty1) (Type ty2) + = match_ty menv subst ty1 ty2 -{- I don't buy this let-rule any more - The let rule fails on matching - forall f,x,xs. f (x:xs) - against - f (let y = e in (y:[])) - because we just get x->y, which is bogus. +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 } -- 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. Meanwhile, we can't get false matches because --- (also by assumption) the term being matched has no shadowing. -match e1 (Let bind e2) tpl_vars kont subst - = match e1 e2 tpl_vars kont subst --} - --- 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 e1 (Var v2) tpl_vars kont subst - = case getIdUnfolding v2 of - CoreUnfolding form guidance unfolding - | whnfOrBottom form - -> match e1 unfolding tpl_vars kont subst - - other -> match_fail +-- them when we encounter them. +match menv subst e1 (Let (NonRec x2 r2) e2) + = match menv' subst e1 e2 + where + menv' = menv { me_env = fst (rnBndrR (me_env menv) x2) } + -- It's important to do this renaming. 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. + +-- Everything else fails +match menv subst e1 e2 = Nothing --- We can't cope with lets in the template +------------------------------------------ +match_alts :: MatchEnv + -> SubstEnv + -> [CoreAlt] -- Template + -> [CoreAlt] -- Target + -> Maybe SubstEnv +match_alts menv subst [] [] + = return subst +match_alts menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) + | c1 == c2 + = do { subst1 <- match menv' subst r1 r2 + ; match_alts menv subst1 alts1 alts2 } + where + menv' :: MatchEnv + menv' = menv { me_env = rnBndrs2 (me_env menv) vs1 vs2 } -match e1 e2 tpl_vars kont subst = match_fail +match_alts menv subst alts1 alts2 + = Nothing +\end{code} +Matching Core types: use the matcher in TcType. +Notice that we treat newtypes as opaque. For example, suppose +we have a specialised version of a function at a newtype, say + newtype T = MkT Int +We only want to replace (f T) with f', not (f Int). +\begin{code} ------------------------------------------ -match_alts [] [] tpl_vars kont subst - = kont subst -match_alts ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) tpl_vars kont subst - | c1 == c2 - = bind vs1 vs2 (match r1 r2) tpl_vars - (match_alts alts1 alts2 tpl_vars kont) - subst -match_alts alts1 alts2 tpl_vars kont subst = match_fail - -lt_alt (con1, _, _) (con2, _, _) = con1 < con2 - ----------------------------------------- -bind :: [CoreBndr] -- Template binders - -> [CoreBndr] -- Target binders - -> Matcher result - -> Matcher result --- This makes uses of assumption (A) above. For example, --- this would fail: --- Template: (\x.y) (y is free) --- Target : (\y.y) (y is bound) --- We rename x to y in the template... but then erroneously --- match y against y. But this can't happen because of (A) -bind vs1 vs2 matcher tpl_vars kont subst - = ASSERT( all not_in_subst vs1) - matcher tpl_vars kont' subst' - where - kont' subst'' = kont (unBindSubstList subst'' vs1 vs2) - subst' = bindSubstList subst vs1 vs2 - - -- The unBindSubst relies on no shadowing in the template - not_in_subst v = not (maybeToBool (lookupSubst subst v)) - ----------------------------------------- -match_ty ty1 ty2 tpl_vars kont subst - = case Unify.match ty1 ty2 tpl_vars Just (substEnv subst) of - Nothing -> match_fail - Just senv' -> kont (setSubstEnv subst senv') - ----------------------------------------- -matches [] [] tpl_vars kont subst - = kont subst -matches (e:es) (e':es') tpl_vars kont subst - = match e e' tpl_vars (matches es es' tpl_vars kont) subst -matches es es' tpl_vars kont subst - = match_fail - ----------------------------------------- -mkVarArg :: CoreBndr -> CoreArg -mkVarArg v | isId v = Var v - | otherwise = Type (mkTyVarTy v) +match_ty menv (tv_subst, id_subst) ty1 ty2 + = do { tv_subst' <- Unify.tcMatchTyX menv tv_subst ty1 ty2 + ; return (tv_subst', id_subst) } \end{code} + %************************************************************************ %* * \subsection{Adding a new rule} @@ -346,7 +347,12 @@ mkVarArg v | isId v = Var v %************************************************************************ \begin{code} -addRule :: Id -> CoreRules -> CoreRule -> CoreRules +addRules :: Id -> CoreRules -> [CoreRule] -> CoreRules +addRule :: Id -> CoreRules -> CoreRule -> CoreRules + +-- Add a new rule to an existing bunch of rules. +-- The rules are for the given Id; the Id argument is needed only +-- so that we can exclude the Id from its own RHS free-var set -- Insert the new rule just before a rule that is *less specific* -- than the new one; or at the end if there isn't such a one. @@ -356,131 +362,210 @@ addRule :: Id -> CoreRules -> CoreRule -> CoreRules -- We make no check for rules that unify without one dominating -- the other. Arguably this would be a bug. -addRule id (Rules rules rhs_fvs) (Rule str tpl_vars tpl_args rhs) - = Rules (insert rules) (rhs_fvs `unionVarSet` new_rhs_fvs) - where - new_rule = Rule str tpl_vars' tpl_args rhs' - -- Add occ info to tpl_vars, rhs - - (rhs_uds, rhs') = occurAnalyseExpr isLocallyDefined rhs - (rhs_uds1, tpl_vars') = tagBinders rhs_uds tpl_vars - - insert [] = [new_rule] - insert (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules) - | otherwise = rule : insert rules - - new_is_more_specific rule = maybeToBool (matchRule tpl_var_set rule tpl_args) +addRules id rules rule_list = foldl (addRule id) rules rule_list - tpl_var_set = mkVarSet tpl_vars' - -- Actually we should probably include the free vars of tpl_args, - -- but I can't be bothered +addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _ _) + = Rules (rule:rules) rhs_fvs + -- Put it at the start for lack of anything better - new_rhs_fvs = (exprFreeVars rhs' `minusVarSet` tpl_var_set) `delVarSet` id +addRule id (Rules rules rhs_fvs) rule + = Rules (insertRule rules new_rule) (rhs_fvs `unionVarSet` new_rhs_fvs) + where + new_rule = occurAnalyseRule rule + new_rhs_fvs = ruleRhsFreeVars new_rule `delVarSet` id -- Hack alert! -- Don't include the Id in its own rhs free-var set. -- Otherwise the occurrence analyser makes bindings recursive -- that shoudn't be. E.g. -- RULE: f (f x y) z ==> f x (f y z) -addIdSpecialisations :: Id -> [([CoreBndr], [CoreExpr], CoreExpr)] -> Id -addIdSpecialisations id spec_stuff - = setIdSpecialisation id new_rules +insertRule rules new_rule@(Rule _ _ tpl_vars tpl_args _) + = go rules + where + tpl_var_set = mkInScopeSet (mkVarSet tpl_vars) + -- Actually we should probably include the free vars of tpl_args, + -- but I can't be bothered + + go [] = [new_rule] + go (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules) + | otherwise = rule : go rules + + new_is_more_specific rule = isJust (matchRule noBlackList tpl_var_set rule tpl_args) + +addIdSpecialisations :: Id -> [CoreRule] -> Id +addIdSpecialisations id rules + = setIdSpecialisation id new_specs where - rule_name = _PK_ ("SPEC " ++ showSDoc (ppr id)) - new_rules = foldr add (getIdSpecialisation id) spec_stuff - add (vars, args, rhs) rules = addRule id rules (Rule rule_name vars args rhs) + new_specs = addRules id (idSpecialisation id) rules \end{code} %************************************************************************ %* * -\subsection{Preparing the rule base +\subsection{Looking up a rule} %* * %************************************************************************ \begin{code} -data ProtoCoreRule - = ProtoCoreRule - Bool -- True <=> this rule was defined in this module, - Id -- What Id is it for - CoreRule -- The rule itself - - -pprProtoCoreRule (ProtoCoreRule _ fn rule) = pprCoreRule (Just fn) rule - -lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr]) -lookupRule in_scope fn args - = case getIdSpecialisation fn of - Rules rules _ -> matchRules in_scope rules args - -orphanRule :: ProtoCoreRule -> Bool --- An "orphan rule" is one that is defined in this --- module, but of ran *imported* function. We need --- to track these separately when generating the interface file -orphanRule (ProtoCoreRule local fn _) - = local && not (isLocallyDefined fn) +lookupRule :: (Activation -> Bool) + -> InScopeSet + -> RuleBase -- Ids from other modules + -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr) +lookupRule is_active in_scope rules fn args + = case idSpecialisation fn' of + Rules rules _ -> matchRules is_active in_scope rules args + where + fn' | isLocalId fn = fn + | Just ext_fn <- lookupVarSet (ruleBaseIds rules) fn = ext_fn + | otherwise = fn \end{code} %************************************************************************ %* * -\subsection{Getting the rules ready} +\subsection{Checking a program for failing rule applications} %* * %************************************************************************ +----------------------------------------------------- + Game plan +----------------------------------------------------- + +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} -type RuleBase = (IdSet, -- Imported Ids that have rules attached - IdSet) -- Ids (whether local or imported) mentioned on - -- LHS of some rule; these should be black listed +ruleCheckProgram :: CompilerPhase -> String -> [CoreBind] -> SDoc +-- Report partial matches for rules beginning +-- with the specified string +ruleCheckProgram phase rule_pat binds + | isEmptyBag results + = text "Rule check results: no rule application sites" + | otherwise + = vcat [text "Rule check results:", + line, + vcat [ p $$ line | p <- bagToList results ] + ] + where + results = unionManyBags (map (ruleCheckBind (phase, rule_pat)) binds) + line = text (replicate 20 '-') + +type RuleCheckEnv = (CompilerPhase, String) -- Phase and Pattern + +ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc + -- The Bag returned has one SDoc for each call site found +ruleCheckBind env (NonRec b r) = ruleCheck env r +ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (b,r) <- prs] + +ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc +ruleCheck env (Var v) = emptyBag +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 (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` + unionManyBags [ruleCheck env r | (_,_,r) <- as] + +ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as) +ruleCheckApp env (Var f) as = ruleCheckFun env f as +ruleCheckApp env other as = ruleCheck env other +\end{code} --- The rule Ids and LHS Ids are black-listed; that is, they aren't inlined --- so that the opportunity to apply the rule isn't lost too soon +\begin{code} +ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc +-- Produce a report for all rules matching the predicate +-- saying why it doesn't match the specified application -prepareRuleBase :: [CoreBind] -> [ProtoCoreRule] -> ([CoreBind], RuleBase) -prepareRuleBase binds rules - = (map zap_bind binds, (imported_rule_ids, rule_lhs_fvs)) +ruleCheckFun (phase, pat) fn args + | null name_match_rules = emptyBag + | otherwise = unitBag (ruleAppCheck_help phase fn args name_match_rules) where - (rule_ids, rule_lhs_fvs) = foldr add_rule (emptyVarSet, emptyVarSet) rules - imported_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids - - -- rule_fvs is the set of all variables mentioned in rules - rule_fvs = foldVarSet (unionVarSet . idRuleVars) rule_lhs_fvs rule_ids - - -- Attach the rules for each locally-defined Id to that Id. - -- - This makes the rules easier to look up - -- - It means that transformation rules and specialisations for - -- locally defined Ids are handled uniformly - -- - It keeps alive things that are referred to only from a rule - -- (the occurrence analyser knows about rules attached to Ids) - -- - It makes sure that, when we apply a rule, the free vars - -- of the RHS are more likely to be in scope - -- - -- The LHS and RHS Ids are marked 'no-discard'. - -- This means that the binding won't be discarded EVEN if the binding - -- ends up being trivial (v = w) -- the simplifier would usually just - -- substitute w for v throughout, but we don't apply the substitution to - -- the rules (maybe we should?), so this substitution would make the rule - -- bogus. - zap_bind (NonRec b r) = NonRec (zap_bndr b) r - zap_bind (Rec prs) = Rec [(zap_bndr b, r) | (b,r) <- prs] - - zap_bndr bndr = case lookupVarSet rule_ids bndr of - Just bndr' -> setIdNoDiscard bndr' - Nothing | bndr `elemVarSet` rule_fvs -> setIdNoDiscard bndr - | otherwise -> bndr - -add_rule (ProtoCoreRule _ id rule) - (rule_id_set, rule_fvs) - = (rule_id_set `extendVarSet` new_id, - rule_fvs `unionVarSet` extendVarSet lhs_fvs id) + name_match_rules = case idSpecialisation fn of + Rules rules _ -> filter match rules + match rule = pat `isPrefixOf` unpackFS (ruleName rule) + +ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc +ruleAppCheck_help phase 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)] where - new_id = case lookupVarSet rule_id_set id of - Just id' -> addRuleToId id' rule - Nothing -> addRuleToId id rule - lhs_fvs = ruleSomeLhsFreeVars isId rule - -- Find *all* the free Ids of the LHS, not just - -- locally defined ones!! - -addRuleToId id rule = setIdSpecialisation id (addRule id (getIdSpecialisation id) rule) + n_args = length args + i_args = args `zip` [1::Int ..] + + check_rule rule = rule_herald rule <> colon <+> rule_info rule + + rule_herald (BuiltinRule name _) = + ptext SLIT("Builtin rule") <+> doubleQuotes (ftext name) + rule_herald (Rule name _ _ _ _) = + ptext SLIT("Rule") <+> doubleQuotes (ftext name) + + rule_info rule + | Just (name,_) <- matchRule noBlackList emptyInScopeSet rule args + = text "matches (which is very peculiar!)" + + rule_info (BuiltinRule name fn) = text "does not match" + + rule_info (Rule name act rule_bndrs rule_args _) + | not (isActive phase 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" + | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)" + where + n_rule_args = length rule_args + n_mismatches = length mismatches + mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args, + not (isJust (match_fn rule_arg arg))] + + lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars + match_fn rule_arg arg = match menv emptySubstEnv rule_arg arg + where + in_scope = lhs_fvs `unionVarSet` exprFreeVars arg + menv = ME { me_env = mkRnEnv2 (mkInScopeSet in_scope) + , me_tmpls = mkVarSet rule_bndrs } \end{code} + +%************************************************************************ +%* * +\subsection{Getting the rules ready} +%* * +%************************************************************************ + +\begin{code} +data RuleBase = RuleBase + IdSet -- Ids with their rules in their specialisations + -- Held as a set, so that it can simply be the initial + -- in-scope set in the simplifier + -- This representation is a bit cute, and I wonder if we should + -- change it to use (IdEnv CoreRule) which seems a bit more natural + +ruleBaseIds (RuleBase ids) = ids +emptyRuleBase = RuleBase emptyVarSet + +extendRuleBaseList :: RuleBase -> [IdCoreRule] -> RuleBase +extendRuleBaseList rule_base new_guys + = foldl extendRuleBase rule_base new_guys + +extendRuleBase :: RuleBase -> IdCoreRule -> RuleBase +extendRuleBase (RuleBase rule_ids) (IdCoreRule id _ rule) + = RuleBase (extendVarSet rule_ids new_id) + where + new_id = setIdSpecialisation id (addRule id old_rules rule) + old_rules = idSpecialisation (fromMaybe id (lookupVarSet rule_ids id)) + -- Get the old rules from rule_ids if the Id is already there, but + -- if not, use the Id from the incoming rule. If may be a PrimOpId, + -- in which case it may have rules in its belly already. Seems + -- dreadfully hackoid. + +pprRuleBase :: RuleBase -> SDoc +pprRuleBase (RuleBase rules) = vcat [ pprTidyIdRules id | id <- varSetElems rules ] +\end{code}