diff options
Diffstat (limited to 'compiler/specialise/Rules.hs')
| -rw-r--r-- | compiler/specialise/Rules.hs | 196 |
1 files changed, 110 insertions, 86 deletions
diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs index b5606754e6..ad6a0757cb 100644 --- a/compiler/specialise/Rules.hs +++ b/compiler/specialise/Rules.hs @@ -28,6 +28,8 @@ module Rules ( #include "HsVersions.h" +import GhcPrelude + import CoreSyn -- All of it import Module ( Module, ModuleSet, elemModuleSet ) import CoreSubst @@ -38,7 +40,7 @@ import CoreUtils ( exprType, eqExpr, mkTick, mkTicks, stripTicksTopT, stripTicksTopE, isJoinBind ) import PprCore ( pprRules ) -import Type ( Type, substTy, mkTCvSubst ) +import Type ( Type, Kind, substTy, mkTCvSubst ) import TcType ( tcSplitTyConApp_maybe ) import TysWiredIn ( anyTypeOfKind ) import Coercion @@ -53,7 +55,7 @@ import NameSet import NameEnv import UniqFM import Unify ( ruleMatchTyKiX ) -import BasicTypes ( Activation, CompilerPhase, isActive, pprRuleName ) +import BasicTypes import DynFlags ( DynFlags ) import Outputable import FastString @@ -288,9 +290,10 @@ addRuleInfo (RuleInfo rs1 fvs1) (RuleInfo rs2 fvs2) = RuleInfo (rs1 ++ rs2) (fvs1 `unionDVarSet` fvs2) addIdSpecialisations :: Id -> [CoreRule] -> Id -addIdSpecialisations id [] - = id addIdSpecialisations id rules + | null rules + = id + | otherwise = setIdSpecialisation id $ extendRuleInfo (idSpecialisation id) rules @@ -310,9 +313,8 @@ ruleIsVisible _ BuiltinRule{} = True ruleIsVisible vis_orphs Rule { ru_orphan = orph, ru_origin = origin } = notOrphan orph || origin `elemModuleSet` vis_orphs -{- -Note [Where rules are found] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Where rules are found] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The rules for an Id come from two places: (a) the ones it is born with, stored inside the Id iself (idCoreRules fn), (b) rules added in other modules, stored in the global RuleBase (imp_rules) @@ -348,7 +350,7 @@ mkRuleBase rules = extendRuleBaseList emptyRuleBase rules extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase extendRuleBaseList rule_base new_guys - = foldl extendRuleBase rule_base new_guys + = foldl' extendRuleBase rule_base new_guys unionRuleBase :: RuleBase -> RuleBase -> RuleBase unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2 @@ -411,21 +413,20 @@ lookupRule dflags in_scope is_active fn args rules findBest :: (Id, [CoreExpr]) -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr) -- All these pairs matched the expression --- Return the pair the the most specific rule +-- Return the pair the most specific rule -- The (fn,args) is just for overlap reporting 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 - | debugIsOn = let pp_rule rule = sdocWithPprDebug $ \dbg -> if dbg - then ppr rule - else doubleQuotes (ftext (ruleName rule)) + | debugIsOn = let pp_rule rule + = ifPprDebug (ppr rule) + (doubleQuotes (ftext (ruleName rule))) in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" - (vcat [ sdocWithPprDebug $ \dbg -> if dbg - then text "Expression to match:" <+> ppr fn - <+> sep (map ppr args) - else empty + (vcat [ whenPprDebug $ + text "Expression to match:" <+> ppr fn + <+> sep (map ppr args) , text "Rule 1:" <+> pp_rule rule1 , text "Rule 2:" <+> pp_rule rule2]) $ findBest target (rule1,ans1) prs @@ -517,7 +518,7 @@ matchRule _ in_scope is_active _ args rough_args | ruleCantMatch tpl_tops rough_args = Nothing | otherwise = case matchN in_scope rule_name tpl_vars tpl_args args of - Nothing -> Nothing + Nothing -> Nothing Just (bind_wrapper, tpl_vals) -> Just (bind_wrapper $ rule_fn `mkApps` tpl_vals) where @@ -535,58 +536,82 @@ matchN :: InScopeEnv matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es = do { subst <- go init_menv emptyRuleSubst tmpl_es target_es - ; let (_, matched_es) = mapAccumL lookup_tmpl subst tmpl_vars + ; let (_, matched_es) = mapAccumL lookup_tmpl subst $ + tmpl_vars `zip` tmpl_vars1 ; return (rs_binds subst, matched_es) } where - init_rn_env = mkRnEnv2 (extendInScopeSetList in_scope tmpl_vars) - -- See Note [Template binders] + (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars + -- See Note [Cloning the template binders] - init_menv = RV { rv_tmpls = mkVarSet tmpl_vars, rv_lcl = init_rn_env - , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env) - , rv_unf = id_unf } + init_menv = RV { rv_tmpls = mkVarSet tmpl_vars1 + , rv_lcl = init_rn_env + , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env) + , rv_unf = id_unf } 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 } - lookup_tmpl :: RuleSubst -> Var -> (RuleSubst, CoreExpr) - lookup_tmpl rs@(RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) tmpl_var - | isId tmpl_var - = case lookupVarEnv id_subst tmpl_var of + lookup_tmpl :: RuleSubst -> (InVar,OutVar) -> (RuleSubst, CoreExpr) + -- Need to return a RuleSubst solely for the benefit of mk_fake_ty + lookup_tmpl rs@(RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) + (tmpl_var, tmpl_var1) + | isId tmpl_var1 + = case lookupVarEnv id_subst tmpl_var1 of Just e -> (rs, e) - Nothing | Just refl_co <- isReflCoVar_maybe tmpl_var - , let co_expr = Coercion refl_co - -> (rs { rs_id_subst = extendVarEnv id_subst tmpl_var co_expr }, co_expr) + Nothing | Just refl_co <- isReflCoVar_maybe tmpl_var1 + , let co_expr = Coercion refl_co + id_subst' = extendVarEnv id_subst tmpl_var1 co_expr + rs' = rs { rs_id_subst = id_subst' } + -> (rs', co_expr) -- See Note [Unbound RULE binders] | otherwise -> unbound tmpl_var | otherwise - = case lookupVarEnv tv_subst tmpl_var of + = case lookupVarEnv tv_subst tmpl_var1 of Just ty -> (rs, Type ty) - Nothing -> (rs { rs_tv_subst = extendVarEnv tv_subst tmpl_var fake_ty }, Type fake_ty) - -- See Note [Unbound RULE binders] + Nothing -> (rs', Type fake_ty) -- See Note [Unbound RULE binders] where - fake_ty = anyTypeOfKind kind - cv_subst = to_co_env id_subst - kind = Type.substTy (mkTCvSubst in_scope (tv_subst, cv_subst)) - (tyVarKind tmpl_var) - - to_co_env env = nonDetFoldUFM_Directly to_co emptyVarEnv env - -- It's OK to use nonDetFoldUFM_Directly because we forget the - -- order immediately by creating a new env - to_co uniq expr env - | Just co <- exprToCoercion_maybe expr - = extendVarEnv_Directly env uniq co - - | otherwise - = env - - unbound var = pprPanic "Template variable unbound in rewrite rule" $ - vcat [ text "Variable:" <+> ppr var - , text "Rule" <+> pprRuleName rule_name - , text "Rule bndrs:" <+> ppr tmpl_vars - , text "LHS args:" <+> ppr tmpl_es - , text "Actual args:" <+> ppr target_es ] + rs' = rs { rs_tv_subst = extendVarEnv tv_subst tmpl_var1 fake_ty } + fake_ty = mk_fake_ty in_scope rs tmpl_var1 + -- This call is the sole reason we accumulate + -- RuleSubst in lookup_tmpl + + unbound tmpl_var + = pprPanic "Template variable unbound in rewrite rule" $ + vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var) + , text "Rule" <+> pprRuleName rule_name + , text "Rule bndrs:" <+> ppr tmpl_vars + , text "LHS args:" <+> ppr tmpl_es + , text "Actual args:" <+> ppr target_es ] + + +mk_fake_ty :: InScopeSet -> RuleSubst -> TyVar -> Kind +-- Roughly: +-- mk_fake_ty subst tv = Any @(subst (tyVarKind tv)) +-- That is: apply the substitution to the kind of the given tyvar, +-- and make an 'any' type of that kind. +-- Tiresomely, the RuleSubst is not well adapted to substTy, leading to +-- horrible impedence matching. +-- +-- Happily, this function is seldom called +mk_fake_ty in_scope (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) tmpl_var1 + = anyTypeOfKind kind + where + kind = Type.substTy (mkTCvSubst in_scope (tv_subst, cv_subst)) + (tyVarKind tmpl_var1) + + cv_subst = to_co_env id_subst + + to_co_env :: IdSubstEnv -> CvSubstEnv + to_co_env env = nonDetFoldUFM_Directly to_co emptyVarEnv env + -- It's OK to use nonDetFoldUFM_Directly because we forget the + -- order immediately by creating a new env + + to_co uniq expr env + = case exprToCoercion_maybe expr of + Just co -> extendVarEnv_Directly env uniq co + Nothing -> env {- Note [Unbound RULE binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -631,8 +656,8 @@ bound on the LHS: in Trac #13410, and also in test T10602. -Note [Template binders] -~~~~~~~~~~~~~~~~~~~~~~~ +Note [Cloning the template binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following match (example 1): Template: forall x. f x Target: f (x+1) @@ -643,21 +668,19 @@ Likewise this one (example 2): Template: forall x. f (\x.x) Target: f (\y.y) -We achieve this simply by: - * Adding forall'd template binders to the in-scope set - -This works even if the template binder are already in scope -(in the target) because +We achieve this simply by using rnBndrL to clone the template +binders if they are already in scope. - * The RuleSubst rs_tv_subst, rs_id_subst maps LHS template vars to - the target world. It is not applied recursively. - - * Having the template vars in the in-scope set ensures that in - example 2 above, the (\x.x) is cloned to (\x'. x'). - -In the past we used rnBndrL to clone the template variables if -they were already in scope. But (a) that's not necessary and (b) -it complicate the fancy footwork for Note [Unbound template type variables] +------ Historical note ------- +At one point I tried simply adding the template binders to the +in-scope set /without/ cloning them, but that failed in a horribly +obscure way in Trac #14777. Problem was that during matching we look +up target-term variables in the in-scope set (see Note [Lookup +in-scope]). If a target-term variable happens to name-clash with a +template variable, that lookup will find the template variable, which +is /utterly/ bogus. In Trac #14777, this transformed a term variable +into a type variable, and then crashed when we wanted its idInfo. +------ End of historical note ------- ************************************************************************ @@ -673,11 +696,12 @@ it complicate the fancy footwork for Note [Unbound template type variables] -- from nested matches; see the Let case of match, below -- data RuleMatchEnv - = RV { rv_tmpls :: VarSet -- Template variables - , rv_lcl :: RnEnv2 -- Renamings for *local bindings* + = RV { rv_lcl :: RnEnv2 -- Renamings for *local bindings* -- (lambda/case) + , rv_tmpls :: VarSet -- Template variables + -- (after applying envL of rv_lcl) , rv_fltR :: Subst -- Renamings for floated let-bindings - -- domain disjoint from envR of rv_lcl + -- (domain disjoint from envR of rv_lcl) -- See Note [Matching lets] , rv_unf :: IdUnfoldingFun } @@ -707,7 +731,6 @@ emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv -- For a start, in general eta expansion wastes work. -- SLPJ July 99 - match :: RuleMatchEnv -> RuleSubst -> CoreExpr -- Template @@ -738,7 +761,8 @@ match _ _ e@Tick{} _ -- succeed in matching what looks like the template variable 'a' against 3. -- The Var case follows closely what happens in Unify.match -match renv subst (Var v1) e2 = match_var renv subst v1 e2 +match renv subst (Var v1) e2 + = match_var renv subst v1 e2 match renv subst e1 (Var v2) -- Note [Expanding variables] | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables] @@ -883,7 +907,7 @@ match_alts renv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) = do { subst1 <- match renv' subst r1 r2 ; match_alts renv subst1 alts1 alts2 } where - renv' = foldl mb renv (vs1 `zip` vs2) + renv' = foldl' mb renv (vs1 `zip` vs2) mb renv (v1,v2) = rnMatchBndr2 renv subst v1 v2 match_alts _ _ _ _ @@ -1110,19 +1134,19 @@ SpecConstr sees this fragment: 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 + $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 ;] + $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 +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 @@ -1147,10 +1171,10 @@ is so important. -- string for the purposes of error reporting ruleCheckProgram :: CompilerPhase -- ^ Rule activation test -> String -- ^ Rule pattern - -> RuleEnv -- ^ Database of rules + -> (Id -> [CoreRule]) -- ^ Rules for an Id -> CoreProgram -- ^ Bindings to check in -> SDoc -- ^ Resulting check message -ruleCheckProgram phase rule_pat rule_base binds +ruleCheckProgram phase rule_pat rules binds | isEmptyBag results = text "Rule check results: no rule application sites" | otherwise @@ -1163,7 +1187,7 @@ ruleCheckProgram phase rule_pat rule_base binds , rc_id_unf = idUnfolding -- Not quite right -- Should use activeUnfolding , rc_pattern = rule_pat - , rc_rule_base = rule_base } + , rc_rules = rules } results = unionManyBags (map (ruleCheckBind env) binds) line = text (replicate 20 '-') @@ -1171,7 +1195,7 @@ data RuleCheckEnv = RuleCheckEnv { rc_is_active :: Activation -> Bool, rc_id_unf :: IdUnfoldingFun, rc_pattern :: String, - rc_rule_base :: RuleEnv + rc_rules :: Id -> [CoreRule] } ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc @@ -1205,7 +1229,7 @@ ruleCheckFun env fn args | null name_match_rules = emptyBag | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules) where - name_match_rules = filter match (getRules (rc_rule_base env) fn) + name_match_rules = filter match (rc_rules env fn) match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule) ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc |