X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FRules.lhs;h=d788b1b391c94f8892ad85ca6962ad7d87bc700b;hb=bd78c94a3b41f8d2097efc0415fa26e0cd1140ef;hp=03038337268fc8a93b4aa44e7c7d318cc73acd7b;hpb=2a8123e1eaac6198fdf1c029561dddffc1ab2cff;p=ghc-hetmet.git diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index 0303833..d788b1b 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -4,13 +4,6 @@ \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 ( @@ -29,7 +22,7 @@ module Rules ( addIdSpecialisations, -- * Misc. CoreRule helpers - rulesOfBinds, + rulesOfBinds, getRules, pprRulesForUser, lookupRule, mkLocalRule, roughTopNames ) where @@ -39,11 +32,9 @@ module Rules ( import CoreSyn -- All of it import OccurAnal ( occurAnalyseExpr ) import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars ) -import CoreUnfold ( isCheapUnfolding, unfoldingTemplate ) import CoreUtils ( tcEqExprX, exprType ) import PprCore ( pprRules ) import Type ( Type, TvSubstEnv ) -import Coercion ( coercionKind ) import TcType ( tcSplitTyConApp_maybe ) import CoreTidy ( tidyRules ) import Id @@ -54,7 +45,7 @@ import VarSet 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 @@ -129,10 +120,10 @@ roughTopName :: CoreExpr -> Maybe Name roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of Just (tc,_) -> Just (getName tc) Nothing -> Nothing -roughTopName (App f a) = roughTopName f +roughTopName (App f _) = roughTopName f roughTopName (Var f) | isGlobalId f = Just (idName f) | otherwise = Nothing -roughTopName other = Nothing +roughTopName _ = Nothing ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool -- ^ @ruleCantMatch tpl actual@ returns True only if @actual@ @@ -148,8 +139,24 @@ ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool -- Reason: a local variable @v@ in the actuals might [_$_] ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as -ruleCantMatch (t : ts) (a : as) = ruleCantMatch ts as -ruleCantMatch ts as = False +ruleCantMatch (_ : ts) (_ : as) = ruleCantMatch ts as +ruleCantMatch _ _ = 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} @@ -174,6 +181,8 @@ addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2) = SpecInfo (rs1 ++ rs2) (fvs1 `unionVarSet` fvs2) addIdSpecialisations :: Id -> [CoreRule] -> Id +addIdSpecialisations id [] + = id addIdSpecialisations id rules = setIdSpecialisation id $ extendSpecInfo (idSpecialisation id) rules @@ -181,6 +190,18 @@ addIdSpecialisations 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} @@ -196,6 +217,7 @@ type RuleBase = NameEnv [CoreRule] -- The rules are are unordered; -- we sort out any overlaps on lookup +emptyRuleBase :: RuleBase emptyRuleBase = emptyNameEnv mkRuleBase :: [CoreRule] -> RuleBase @@ -241,37 +263,17 @@ 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 the active --- rules in a given 'RuleBase' to this instance of an application --- in a given context, returning the rule applied and the resulting --- expression if successful. -lookupRule :: (Activation -> Bool) -- ^ Activation test - -> InScopeSet -- ^ Variables that are in scope at this point - -> RuleBase -- ^ Imported rules - -> Id -- ^ Function 'Id' to lookup a rule by - -> [CoreExpr] -- ^ Arguments to function - -> 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 (getRules rule_base fn) - -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 - -matchRules :: (Activation -> Bool) -> InScopeSet - -> Id -> [CoreExpr] - -> [CoreRule] -> Maybe (CoreRule, CoreExpr) +-- | 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 + -> Id -> [CoreExpr] + -> [CoreRule] -> Maybe (CoreRule, CoreExpr) + +-- See Note [Extra args in rule matching] -- See comments on matchRule -matchRules is_active in_scope fn args rules +lookupRule is_active in_scope fn args rules = -- pprTrace "matchRules" (ppr fn <+> ppr rules) $ case go [] rules of [] -> Nothing @@ -284,7 +286,7 @@ matchRules is_active in_scope fn args rules go ms (r:rs) = case (matchRule is_active in_scope args rough_args r) of Just e -> go ((r,e):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] ) + -- ppr [(arg_id, unfoldingTemplate unf) | Var arg_id <- args, let unf = idUnfolding arg_id, isCheapUnfolding unf] ) go ms rs findBest :: (Id, [CoreExpr]) @@ -293,7 +295,7 @@ findBest :: (Id, [CoreExpr]) -- Return the pair the the most specific rule -- The (fn,args) is just for overlap reporting -findBest target (rule,ans) [] = (rule,ans) +findBest _ (rule,ans) [] = (rule,ans) findBest target (rule1,ans1) ((rule2,ans2):prs) | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs @@ -312,8 +314,8 @@ findBest target (rule1,ans1) ((rule2,ans2):prs) (fn,args) = target isMoreSpecific :: CoreRule -> CoreRule -> Bool -isMoreSpecific (BuiltinRule {}) r2 = True -isMoreSpecific r1 (BuiltinRule {}) = False +isMoreSpecific (BuiltinRule {}) _ = True +isMoreSpecific _ (BuiltinRule {}) = False isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 }) (Rule { ru_bndrs = bndrs2, ru_args = args2 }) = isJust (matchN in_scope bndrs2 args2 args1) @@ -323,7 +325,7 @@ isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 }) -- of rule1's args, but I can't be bothered noBlackList :: Activation -> Bool -noBlackList act = False -- Nothing is black listed +noBlackList _ = False -- Nothing is black listed matchRule :: (Activation -> Bool) -> InScopeSet -> [CoreExpr] -> [Maybe Name] @@ -351,14 +353,14 @@ matchRule :: (Activation -> Bool) -> InScopeSet -- Any 'surplus' arguments in the input are simply put on the end -- of the output. -matchRule is_active in_scope args rough_args - (BuiltinRule { ru_name = name, ru_try = match_fn }) +matchRule _is_active _in_scope args _rough_args + (BuiltinRule { ru_try = match_fn }) = case match_fn args of Just expr -> Just expr Nothing -> Nothing matchRule is_active in_scope args rough_args - (Rule { ru_name = rn, ru_act = act, ru_rough = tpl_tops, + (Rule { ru_act = act, ru_rough = tpl_tops, ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) | not (is_active act) = Nothing @@ -395,8 +397,8 @@ matchN in_scope tmpl_vars tmpl_es target_es init_menv = ME { me_tmpls = mkVarSet tmpl_vars', me_env = init_rn_env } - go menv subst [] es = Just subst - go menv subst ts [] = Nothing -- Fail if too few actual args + go _ subst [] _ = Just subst + go _ _ _ [] = 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 } @@ -407,7 +409,7 @@ matchN in_scope tmpl_vars tmpl_es target_es Nothing -> unbound tmpl_var' | otherwise = case lookupVarEnv id_subst tmpl_var' of Just e -> e - other -> unbound tmpl_var' + _ -> unbound tmpl_var' unbound var = pprPanic "Template variable unbound in rewrite rule" (ppr var $$ ppr tmpl_vars $$ ppr tmpl_vars' $$ ppr tmpl_es $$ ppr target_es) @@ -486,7 +488,7 @@ match menv subst (Var v1) e2 | Just subst <- match_var menv subst v1 e2 = Just subst -match menv subst e1 (Note n e2) +match menv subst e1 (Note _ e2) = match menv subst e1 e2 -- Note [Notes in RULE matching] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -558,7 +560,7 @@ Watch out! 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) +match menv (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' }) @@ -584,7 +586,7 @@ match menv subst@(tv_subst, id_subst, binds) e1 (Let bind e2) Rec {} -> Rec (bndrs' `zip` map (substExpr subst) rhss) -} -match menv subst (Lit lit1) (Lit lit2) +match _ subst (Lit lit1) (Lit lit2) | lit1 == lit2 = Just subst @@ -657,7 +659,7 @@ match menv subst e1 (Let bind e2) -} -- Everything else fails -match menv subst e1 e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr e1) $$ (text "e2:" <+> ppr e2)) $ +match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr e1) $$ (text "e2:" <+> ppr e2)) $ Nothing ------------------------------------------ @@ -698,7 +700,7 @@ match_var menv subst@(tv_subst, id_subst, binds) v1 e2 | 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 + _ -> Nothing where rn_env = me_env menv @@ -715,7 +717,7 @@ match_alts :: MatchEnv -> [CoreAlt] -- Template -> [CoreAlt] -- Target -> Maybe SubstEnv -match_alts menv subst [] [] +match_alts _ subst [] [] = return subst match_alts menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) | c1 == c2 @@ -725,7 +727,7 @@ match_alts menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) menv' :: MatchEnv menv' = menv { me_env = rnBndrs2 (me_env menv) vs1 vs2 } -match_alts menv subst alts1 alts2 +match_alts _ _ _ _ = Nothing \end{code} @@ -800,12 +802,12 @@ This pass runs over the tree (without changing it) and reports such. \begin{code} -- | Report partial matches for rules beginning with the specified -- string for the purposes of error reporting -ruleCheckProgram :: CompilerPhase -- ^ Phase to check in +ruleCheckProgram :: (Activation -> Bool) -- ^ Rule activation test -> String -- ^ Rule pattern -> RuleBase -- ^ Database of rules -> [CoreBind] -- ^ Bindings to check in -> SDoc -- ^ Resulting check message -ruleCheckProgram phase rule_pat rule_base binds +ruleCheckProgram is_active rule_pat rule_base binds | isEmptyBag results = text "Rule check results: no rule application sites" | otherwise @@ -814,31 +816,36 @@ ruleCheckProgram phase rule_pat rule_base binds vcat [ p $$ line | p <- bagToList results ] ] where - results = unionManyBags (map (ruleCheckBind (phase, rule_pat, rule_base)) binds) + results = unionManyBags (map (ruleCheckBind (RuleCheckEnv is_active rule_pat rule_base)) binds) line = text (replicate 20 '-') -type RuleCheckEnv = (CompilerPhase, String, RuleBase) -- 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 -ruleCheckBind env (NonRec b r) = ruleCheck env r -ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (b,r) <- prs] +ruleCheckBind env (NonRec _ r) = ruleCheck env r +ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs] ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc -ruleCheck env (Var v) = emptyBag -ruleCheck env (Lit l) = emptyBag -ruleCheck env (Type ty) = emptyBag +ruleCheck _ (Var _) = emptyBag +ruleCheck _ (Lit _) = emptyBag +ruleCheck _ (Type _) = 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 (Note _ e) = ruleCheck env e +ruleCheck env (Cast 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 (Lam _ e) = ruleCheck env e ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags` unionManyBags [ruleCheck env r | (_,_,r) <- as] +ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc 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 +ruleCheckApp env other _ = ruleCheck env other \end{code} \begin{code} @@ -846,15 +853,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, rule_base) 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 (getRules rule_base 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)] @@ -876,9 +883,9 @@ ruleAppCheck_help phase fn args rules rule_info (BuiltinRule {}) = text "does not match" - rule_info (Rule { ru_name = name, ru_act = act, + rule_info (Rule { 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"