X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FRules.lhs;h=9d77aaf56bfc3302d52bcdd5fe0961e9ad346b47;hb=9df1b97e2fcd4df84542547d57965cd46ccedcc6;hp=8406b0a49876fa4264af0d2d6fb6ab8a0c06a2ac;hpb=9d38678ea60ff32f756390a30c659daa22c98c93;p=ghc-hetmet.git diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index 8406b0a..9d77aaf 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -5,10 +5,10 @@ \begin{code} module Rules ( - RuleBase, prepareRuleBase, lookupRule, - addIdSpecialisations, + RuleBase, prepareLocalRuleBase, prepareOrphanRuleBase, + unionRuleBase, lookupRule, addRule, addIdSpecialisations, ProtoCoreRule(..), pprProtoCoreRule, - orphanRule + localRule, orphanRule ) where #include "HsVersions.h" @@ -18,17 +18,17 @@ import OccurAnal ( occurAnalyseExpr, tagBinders, UsageDetails ) import BinderInfo ( markMany ) import CoreFVs ( exprFreeVars, idRuleVars, ruleSomeLhsFreeVars ) import CoreUnfold ( isCheapUnfolding, unfoldingTemplate ) -import CoreUtils ( eqExpr ) +import CoreUtils ( eqExpr, cheapEqExpr ) import PprCore ( pprCoreRule ) import Subst ( Subst, InScopeSet, substBndr, lookupSubst, extendSubst, mkSubst, substEnv, setSubstEnv, emptySubst, isInScope, - unBindSubst, bindSubstList, unBindSubstList, + unBindSubst, bindSubstList, unBindSubstList, substInScope ) -import Id ( Id, getIdUnfolding, - getIdSpecialisation, setIdSpecialisation, +import Id ( Id, idUnfolding, zapLamIdInfo, + idSpecialisation, setIdSpecialisation, setIdNoDiscard, maybeModifyIdInfo, modifyIdInfo ) -import IdInfo ( zapLamIdInfo, setSpecInfo, specInfo ) +import IdInfo ( setSpecInfo, specInfo ) import Name ( Name, isLocallyDefined ) import Var ( isTyVar, isId ) import VarSet @@ -88,7 +88,7 @@ where pi' :: Lift Int# is the specialised version of pi. %************************************************************************ \begin{code} -matchRules :: InScopeSet -> [CoreRule] -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr]) +matchRules :: InScopeSet -> [CoreRule] -> [CoreExpr] -> Maybe (RuleName, CoreExpr) -- See comments on matchRule matchRules in_scope [] args = Nothing matchRules in_scope (rule:rules) args @@ -97,11 +97,11 @@ matchRules in_scope (rule:rules) args Nothing -> matchRules in_scope rules args -matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr]) +matchRule :: 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 -- @@ -116,7 +116,7 @@ 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. @@ -142,8 +142,10 @@ matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (FAST_STRING, CoreExp -- (\x->E) matches (\x->F x) -matchRule in_scope (Rule rn tpl_vars tpl_args rhs) args - = go tpl_args args emptySubst +matchRule in_scope rule@(BuiltinRule match_fn) args = match_fn args + +matchRule in_scope rule@(Rule rn tpl_vars tpl_args rhs) args + = 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 where @@ -154,14 +156,25 @@ matchRule in_scope (Rule rn tpl_vars tpl_args rhs) args 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) + go [] [] subst = Just (rn, app_match subst (mkLams tpl_vars rhs) tpl_vars) + go [] args subst = Just (rn, app_match subst (mkLams tpl_vars rhs) tpl_vars `mkApps` args) -- One tiresome way to terminate: check for excess unmatched -- template arguments - go tpl_args [] subst = Nothing -- Failure + go tpl_args [] subst = Nothing -- Failure + + + ----------------------- + app_match subst fn vs = foldl go fn vs + where + senv = substEnv subst + go fn v = case lookupSubstEnv senv v of + Just (DoneEx ex) -> fn `App` ex + Just (DoneTy ty) -> fn `App` Type ty + -- Substitution should bind them all! + ----------------------- {- The code below tries to match even if there are more template args than real args. @@ -200,22 +213,13 @@ matchRule in_scope (Rule rn tpl_vars tpl_args rhs) args 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 + | otherwise = zapLamIdInfo bndr \end{code} \begin{code} -type Matcher result = IdOrTyVarSet -- Template variables +type Matcher result = VarSet -- 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 @@ -248,9 +252,9 @@ match (Var v1) e2 tpl_vars kont subst other -> match_fail -match (Con c1 es1) (Con c2 es2) tpl_vars kont subst - | c1 == c2 - = matches es1 es2 tpl_vars kont subst +match (Lit lit1) (Lit lit2) tpl_vars kont subst + | lit1 == lit2 + = kont subst match (App f1 a1) (App f2 a2) tpl_vars kont subst = match f1 f2 tpl_vars (match a1 a2 tpl_vars kont) subst @@ -269,7 +273,16 @@ match (Lam x1 e1) e2 tpl_vars kont subst -- 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 - = bind [x2] [x2] (match (App e1 (mkVarArg x2)) e2) tpl_vars kont subst + = bind [new_id] [x2] (match (App e1 (mkVarArg new_id)) e2) tpl_vars kont subst + where + new_id = uniqAway (substInScope subst) x2 + -- This uniqAway is actually needed. Here's the example: + -- rule: foldr (mapFB (:) f) [] = mapList + -- target: foldr (\x. mapFB k f x) [] + -- where + -- k = \x. mapFB ... x + -- The first \x is ok, but when we inline k, hoping it might + -- match (:) we find a second \x. match (Case e1 x1 alts1) (Case e2 x2 alts2) tpl_vars kont subst = match e1 e2 tpl_vars case_kont subst @@ -311,7 +324,7 @@ match e1 (Var v2) tpl_vars kont subst | isCheapUnfolding unfolding = match e1 (unfoldingTemplate unfolding) tpl_vars kont subst where - unfolding = getIdUnfolding v2 + unfolding = idUnfolding v2 -- We can't cope with lets in the template @@ -343,7 +356,7 @@ bind :: [CoreBndr] -- Template binders -- 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) + = WARN( not (all not_in_subst vs1), bug_msg ) matcher tpl_vars kont' subst' where kont' subst'' = kont (unBindSubstList subst'' vs1 vs2) @@ -351,6 +364,7 @@ bind vs1 vs2 matcher tpl_vars kont subst -- The unBindSubst relies on no shadowing in the template not_in_subst v = not (maybeToBool (lookupSubst subst v)) + bug_msg = sep [ppr vs1, ppr vs2] ---------------------------------------- match_ty ty1 ty2 tpl_vars kont subst @@ -389,6 +403,10 @@ 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 _) + = Rules (rule:rules) rhs_fvs + -- Put it at the start for lack of anything better + addRule id (Rules rules rhs_fvs) (Rule str tpl_vars tpl_args rhs) = Rules (insert rules) (rhs_fvs `unionVarSet` new_rhs_fvs) where @@ -420,7 +438,7 @@ addIdSpecialisations id spec_stuff = setIdSpecialisation id new_rules where rule_name = _PK_ ("SPEC " ++ showSDoc (ppr id)) - new_rules = foldr add (getIdSpecialisation id) spec_stuff + new_rules = foldr add (idSpecialisation id) spec_stuff add (vars, args, rhs) rules = addRule id rules (Rule rule_name vars args rhs) \end{code} @@ -441,14 +459,17 @@ data ProtoCoreRule pprProtoCoreRule (ProtoCoreRule _ fn rule) = pprCoreRule (Just fn) rule -lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr]) +lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr) lookupRule in_scope fn args - = case getIdSpecialisation fn of + = 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 of ran *imported* function. We need +-- 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) @@ -466,17 +487,32 @@ 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 +unionRuleBase (rule_ids1, black_ids1) (rule_ids2, black_ids2) + = (plusUFM_C merge_rules rule_ids1 rule_ids2, + unionVarSet black_ids1 black_ids2) + 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 -prepareRuleBase :: [CoreBind] -> [ProtoCoreRule] -> ([CoreBind], RuleBase) -prepareRuleBase binds rules - = (map zap_bind binds, (imported_rule_ids, rule_lhs_fvs)) +prepareLocalRuleBase :: [CoreBind] -> [ProtoCoreRule] -> ([CoreBind], RuleBase) +prepareLocalRuleBase binds local_rules + = (map zap_bind binds, (imported_id_rule_ids, rule_lhs_fvs)) where - (rule_ids, rule_lhs_fvs) = foldr add_rule (emptyVarSet, emptyVarSet) rules - imported_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids + (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 rules + -- 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. @@ -514,6 +550,12 @@ add_rule (ProtoCoreRule _ id rule) -- Find *all* the free Ids of the LHS, not just -- locally defined ones!! -addRuleToId id rule = setIdSpecialisation id (addRule id (getIdSpecialisation id) rule) -\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. + +prepareOrphanRuleBase :: [ProtoCoreRule] -> RuleBase +prepareOrphanRuleBase imported_rules + = foldr add_rule (emptyVarSet, emptyVarSet) imported_rules +\end{code}