X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FRules.lhs;h=e66e048eff7ca3c4c0e8da0f1f128884821132b8;hb=36d22a1cb608e8572776ab6d402fd0c1a9287dc5;hp=e09dc22c0b24961cbbf534bf41f659406de9375d;hpb=79a8b87c0bd61d56b4cf45bd584c9174aab48e61;p=ghc-hetmet.git diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index e09dc22..e66e048 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -9,7 +9,7 @@ module Rules ( extendRuleBaseList, ruleBaseIds, pprRuleBase, ruleCheckProgram, - lookupRule, addRule, addIdSpecialisations + lookupRule, addRule, addRules, addIdSpecialisations ) where #include "HsVersions.h" @@ -19,20 +19,18 @@ import OccurAnal ( occurAnalyseRule ) import CoreFVs ( exprFreeVars, exprsFreeVars, ruleRhsFreeVars ) import CoreUnfold ( isCheapUnfolding, unfoldingTemplate ) import CoreUtils ( tcEqExprX ) +import Type ( Type ) import CoreTidy ( pprTidyIdRules ) -import Subst ( IdSubstEnv, SubstResult(..) ) -import Id ( Id, idUnfolding, idSpecialisation, setIdSpecialisation ) +import Id ( Id, idUnfolding, isLocalId, idSpecialisation, setIdSpecialisation ) import Var ( Var ) import VarSet import VarEnv -import TcType ( TvSubstEnv ) import Unify ( tcMatchTyX, MatchEnv(..) ) import BasicTypes ( Activation, CompilerPhase, isActive ) import Outputable import FastString import Maybe ( isJust, fromMaybe ) -import Util ( sortLe ) import Bag import List ( isPrefixOf ) \end{code} @@ -157,12 +155,27 @@ matchN in_scope tmpl_vars tmpl_es target_es Just ty -> Type ty Nothing -> unbound tmpl_var | otherwise = case lookupVarEnv id_subst tmpl_var of - Just (DoneEx e) -> e - other -> unbound tmpl_var + Just e -> e + other -> unbound tmpl_var unbound var = pprPanic "Template variable unbound in rewrite rule" (ppr var) +\end{code} + -emptySubstEnv :: (TvSubstEnv, IdSubstEnv) + --------------------------------------------- + The inner workings of matching + --------------------------------------------- + +\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 + +emptySubstEnv :: SubstEnv emptySubstEnv = (emptyVarEnv, emptyVarEnv) @@ -176,10 +189,10 @@ emptySubstEnv = (emptyVarEnv, emptyVarEnv) match :: MatchEnv - -> (TvSubstEnv, IdSubstEnv) + -> SubstEnv -> CoreExpr -- Template -> CoreExpr -- Target - -> Maybe (TvSubstEnv, IdSubstEnv) + -> Maybe SubstEnv -- See the notes with Unify.match, which matches types -- Everything is very similar for terms @@ -205,10 +218,10 @@ match menv subst@(tv_subst, id_subst) (Var v1) e2 -- e.g. match forall a. (\x-> a x) against (\y. y y) | otherwise - -> Just (tv_subst, extendVarEnv id_subst v1 (DoneEx e2)) + -> Just (tv_subst, extendVarEnv id_subst v1 e2) - Just (DoneEx e2') | tcEqExprX (nukeRnEnvL rn_env) e2' e2 - -> Just subst + Just e2' | tcEqExprX (nukeRnEnvL rn_env) e2' e2 + -> Just subst other -> Nothing @@ -263,7 +276,7 @@ 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 (sortLe le_alt alts1) (sortLe le_alt alts2) + ; match_alts menv' subst2 alts1 alts2 -- Alts are both sorted } match menv subst (Type ty1) (Type ty2) @@ -295,10 +308,10 @@ match menv subst e1 e2 = Nothing ------------------------------------------ match_alts :: MatchEnv - -> (TvSubstEnv, IdSubstEnv) + -> SubstEnv -> [CoreAlt] -- Template -> [CoreAlt] -- Target - -> Maybe (TvSubstEnv, IdSubstEnv) + -> Maybe SubstEnv match_alts menv subst [] [] = return subst match_alts menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) @@ -311,8 +324,6 @@ match_alts menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) match_alts menv subst alts1 alts2 = Nothing - -le_alt (con1, _, _) (con2, _, _) = con1 <= con2 \end{code} Matching Core types: use the matcher in TcType. @@ -336,7 +347,8 @@ match_ty menv (tv_subst, id_subst) ty1 ty2 %************************************************************************ \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 @@ -350,6 +362,8 @@ addRule :: Id -> CoreRules -> CoreRule -> CoreRules -- We make no check for rules that unify without one dominating -- the other. Arguably this would be a bug. +addRules id rules rule_list = foldl (addRule id) rules rule_list + addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _ _) = Rules (rule:rules) rhs_fvs -- Put it at the start for lack of anything better @@ -382,7 +396,7 @@ addIdSpecialisations :: Id -> [CoreRule] -> Id addIdSpecialisations id rules = setIdSpecialisation id new_specs where - new_specs = foldl (addRule id) (idSpecialisation id) rules + new_specs = addRules id (idSpecialisation id) rules \end{code} @@ -393,11 +407,17 @@ addIdSpecialisations id rules %************************************************************************ \begin{code} -lookupRule :: (Activation -> Bool) -> InScopeSet +lookupRule :: (Activation -> Bool) + -> InScopeSet + -> RuleBase -- Ids from other modules -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr) -lookupRule is_active in_scope fn args - = case idSpecialisation fn of +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} @@ -450,7 +470,6 @@ 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 --- gaw 2004 ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags` unionManyBags [ruleCheck env r | (_,_,r) <- as]