X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FRules.lhs;h=4f538599202d1cfac7f6261b5efd8de3a4d15477;hb=59c796f8e77325d35f29ddd3e724bfa780466d40;hp=6e7c6c233d57785070c499d07e4462eebe24c18a;hpb=495ef8bd9ef30bffe50ea399b91e3ba09646b59a;p=ghc-hetmet.git diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index 6e7c6c2..4f53859 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -5,43 +5,39 @@ \begin{code} module Rules ( - RuleBase, prepareLocalRuleBase, prepareOrphanRuleBase, - unionRuleBase, lookupRule, addRule, addIdSpecialisations, - ProtoCoreRule(..), pprProtoCoreRule, - localRule, orphanRule + RuleBase, emptyRuleBase, + extendRuleBaseList, + ruleBaseIds, pprRuleBase, ruleCheckProgram, + + lookupRule, addRule, addIdSpecialisations ) where #include "HsVersions.h" import CoreSyn -- All of it import OccurAnal ( occurAnalyseRule ) -import BinderInfo ( markMany ) -import CoreFVs ( exprFreeVars, idRuleVars, ruleRhsFreeVars, ruleSomeLhsFreeVars ) +import CoreFVs ( exprFreeVars, ruleRhsFreeVars ) import CoreUnfold ( isCheapUnfolding, unfoldingTemplate ) import CoreUtils ( eqExpr ) -import PprCore ( pprCoreRule ) -import Subst ( Subst, InScopeSet, substBndr, lookupSubst, extendSubst, - mkSubst, substEnv, setSubstEnv, emptySubst, isInScope, - unBindSubst, bindSubstList, unBindSubstList, substInScope +import CoreTidy ( pprTidyIdRules ) +import Subst ( Subst, InScopeSet, mkInScopeSet, lookupSubst, extendSubst, + substEnv, setSubstEnv, emptySubst, isInScope, emptyInScopeSet, + bindSubstList, unBindSubstList, substInScope, uniqAway ) -import Id ( Id, idUnfolding, zapLamIdInfo, - idSpecialisation, setIdSpecialisation, - setIdNoDiscard, maybeModifyIdInfo, modifyIdInfo - ) -import Name ( Name, isLocallyDefined ) -import Var ( isTyVar, isId ) +import Id ( Id, idUnfolding, idSpecialisation, setIdSpecialisation ) +import Var ( isId ) import VarSet import VarEnv -import Type ( mkTyVarTy, getTyVar_maybe ) -import qualified Unify ( match ) -import CmdLineOpts ( opt_D_dump_simpl, opt_D_verbose_core2core ) +import TcType ( mkTyVarTy ) +import qualified TcType ( match ) +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, isNothing, fromMaybe ) +import Util ( sortLe ) +import Bag +import List ( isPrefixOf ) \end{code} @@ -87,16 +83,20 @@ where pi' :: Lift Int# is the specialised version of pi. %************************************************************************ \begin{code} -matchRules :: InScopeSet -> [CoreRule] -> [CoreExpr] -> Maybe (RuleName, 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 (RuleName, CoreExpr) +matchRule :: (Activation -> Bool) -> InScopeSet + -> CoreRule -> [CoreExpr] -> Maybe (RuleName, CoreExpr) -- If (matchRule rule args) returns Just (name,rhs) -- then (f args) matches the rule, and the corresponding @@ -141,9 +141,15 @@ matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (RuleName, CoreExpr) -- (\x->E) matches (\x->F x) -matchRule in_scope rule@(BuiltinRule match_fn) args = match_fn args +matchRule is_active in_scope rule@(BuiltinRule name match_fn) args + = case match_fn args of + Just expr -> Just (name,expr) + Nothing -> Nothing -matchRule in_scope rule@(Rule rn tpl_vars tpl_args rhs) args +matchRule is_active in_scope rule@(Rule rn act tpl_vars tpl_args rhs) args + | not (is_active act) + = Nothing + | otherwise = go tpl_args args emptySubst -- We used to use the in_scope set, but I don't think that's necessary -- After all, the result is going to be simplified again with that in_scope set @@ -187,7 +193,7 @@ matchRule in_scope rule@(Rule rn tpl_vars tpl_args rhs) args mk_result_args subst done) Nothing -> Nothing -- Failure where - (done, leftovers) = partition (\v -> maybeToBool (lookupSubstEnv subst_env v)) + (done, leftovers) = partition (\v -> isJust (lookupSubstEnv subst_env v)) (map zapOccInfo tpl_vars) -- Zap the occ info subst_env = substEnv subst @@ -210,11 +216,11 @@ matchRule in_scope rule@(Rule rn tpl_vars tpl_args rhs) args Nothing -> Nothing eta_complete other vars = Nothing --} zapOccInfo bndr | isTyVar bndr = bndr | otherwise = zapLamIdInfo bndr +-} \end{code} \begin{code} @@ -244,10 +250,10 @@ match (Var v1) e2 tpl_vars kont subst kont (extendSubst subst v1 (DoneEx e2)) - | eqExpr (Var v1) e2 -> kont subst + | eqExpr (Var v1) e2 -> kont subst -- v1 is not a template variable, so it must be a global constant - Just (DoneEx e2') | eqExpr e2' e2 -> kont subst + Just (DoneEx e2') | eqExpr e2' e2 -> kont subst other -> match_fail @@ -286,7 +292,7 @@ match e1 (Lam 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 where - case_kont subst = bind [x1] [x2] (match_alts alts1 (sortLt lt_alt alts2)) + case_kont subst = bind [x1] [x2] (match_alts alts1 (sortLe le_alt alts2)) tpl_vars kont subst match (Type ty1) (Type ty2) tpl_vars kont subst @@ -341,7 +347,7 @@ match_alts ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) tpl_vars kont subst subst match_alts alts1 alts2 tpl_vars kont subst = match_fail -lt_alt (con1, _, _) (con2, _, _) = con1 < con2 +le_alt (con1, _, _) (con2, _, _) = con1 <= con2 ---------------------------------------- bind :: [CoreBndr] -- Template binders @@ -362,29 +368,31 @@ bind vs1 vs2 matcher tpl_vars kont subst subst' = bindSubstList subst vs1 vs2 -- The unBindSubst relies on no shadowing in the template - not_in_subst v = not (maybeToBool (lookupSubst subst v)) + not_in_subst v = isNothing (lookupSubst subst v) bug_msg = sep [ppr vs1, ppr vs2] ---------------------------------------- -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) \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_ty ty1 ty2 tpl_vars kont subst + = TcType.match ty1 ty2 tpl_vars kont' (substEnv subst) + where + kont' senv = kont (setSubstEnv subst senv) +\end{code} + + + %************************************************************************ %* * \subsection{Adding a new rule} @@ -394,6 +402,10 @@ mkVarArg v | isId v = Var v \begin{code} 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. -- In this way we make sure that when looking up, the first match @@ -402,7 +414,7 @@ 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@(BuiltinRule _) +addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _ _) = Rules (rule:rules) rhs_fvs -- Put it at the start for lack of anything better @@ -417,10 +429,10 @@ addRule id (Rules rules rhs_fvs) rule -- that shoudn't be. E.g. -- RULE: f (f x y) z ==> f x (f y z) -insertRule rules new_rule@(Rule _ tpl_vars tpl_args _) +insertRule rules new_rule@(Rule _ _ tpl_vars tpl_args _) = go rules where - tpl_var_set = mkVarSet tpl_vars + tpl_var_set = mkInScopeSet (mkVarSet tpl_vars) -- Actually we should probably include the free vars of tpl_args, -- but I can't be bothered @@ -428,131 +440,172 @@ insertRule rules new_rule@(Rule _ tpl_vars tpl_args _) go (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules) | otherwise = rule : go rules - new_is_more_specific rule = maybeToBool (matchRule tpl_var_set rule tpl_args) + new_is_more_specific rule = isJust (matchRule noBlackList tpl_var_set rule tpl_args) -addIdSpecialisations :: Id -> [([CoreBndr], [CoreExpr], CoreExpr)] -> Id -addIdSpecialisations id spec_stuff - = setIdSpecialisation id new_rules +addIdSpecialisations :: Id -> [CoreRule] -> Id +addIdSpecialisations id rules + = setIdSpecialisation id new_specs where - rule_name = _PK_ ("SPEC " ++ showSDoc (ppr id)) - new_rules = foldr add (idSpecialisation id) spec_stuff - add (vars, args, rhs) rules = addRule id rules (Rule rule_name vars args rhs) + new_specs = foldl (addRule 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 (ppr fn) rule - -lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr) -lookupRule in_scope fn args +lookupRule :: (Activation -> Bool) -> InScopeSet + -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr) +lookupRule is_active in_scope fn args = case idSpecialisation fn of - Rules rules _ -> matchRules in_scope rules args - -localRule :: ProtoCoreRule -> Bool -localRule (ProtoCoreRule local _ _) = local - -orphanRule :: ProtoCoreRule -> Bool --- An "orphan rule" is one that is defined in this --- module, but for an *imported* function. We need --- to track these separately when generating the interface file -orphanRule (ProtoCoreRule local fn _) - = local && not (isLocallyDefined fn) + Rules rules _ -> matchRules is_active in_scope rules args \end{code} %************************************************************************ %* * -\subsection{Getting the rules ready} +\subsection{Checking a program for failing rule applications} %* * %************************************************************************ -\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 +----------------------------------------------------- + Game plan +----------------------------------------------------- -unionRuleBase (rule_ids1, black_ids1) (rule_ids2, black_ids2) - = (plusUFM_C merge_rules rule_ids1 rule_ids2, - unionVarSet black_ids1 black_ids2) +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 + | isEmptyBag results + = text "Rule check results: no rule application sites" + | otherwise + = vcat [text "Rule check results:", + line, + vcat [ p $$ line | p <- bagToList results ] + ] where - merge_rules id1 id2 = let rules1 = idSpecialisation id1 - rules2 = idSpecialisation id2 - new_rules = foldl (addRule id1) rules1 (rulesRules rules2) - in - setIdSpecialisation id1 new_rules - --- prepareLocalRuleBase takes the CoreBinds and rules defined in this module. --- It attaches those rules that are for local Ids to their binders, and --- returns the remainder attached to Ids in an IdSet. It also returns --- Ids mentioned on LHS of some rule; these should be blacklisted. - --- 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 - -prepareLocalRuleBase :: [CoreBind] -> [ProtoCoreRule] -> ([CoreBind], RuleBase) -prepareLocalRuleBase binds local_rules - = (map zap_bind binds, (imported_id_rule_ids, rule_lhs_fvs)) + 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} + +\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 + +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) local_rules - imported_id_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids - - -- rule_fvs is the set of all variables mentioned in this module's 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!! + 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 the 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))] + + bndr_set = mkVarSet rule_bndrs + match_fn rule_arg arg = match rule_arg arg bndr_set (\s -> Just ()) emptySubst +\end{code} -addRuleToId id rule = setIdSpecialisation id (addRule id (idSpecialisation id) rule) --- prepareOrphanRuleBase does exactly the same as prepareLocalRuleBase, except that --- it assumes that none of the rules can be attached to local Ids. +%************************************************************************ +%* * +\subsection{Getting the rules ready} +%* * +%************************************************************************ -prepareOrphanRuleBase :: [ProtoCoreRule] -> RuleBase -prepareOrphanRuleBase imported_rules - = foldr add_rule (emptyVarSet, emptyVarSet) imported_rules +\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 -> [(Id,CoreRule)] -> RuleBase +extendRuleBaseList rule_base new_guys + = foldl extendRuleBase rule_base new_guys + +extendRuleBase :: RuleBase -> (Id,CoreRule) -> RuleBase +extendRuleBase (RuleBase rule_ids) (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}