X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FRules.lhs;h=8d8819a9137da0567cf0685b5bb9fc4e2f8c5198;hb=12e6a9a58473f8b24e831c2171bf62d256da8a85;hp=f1d29bdf6744ebf0bbb3b8381369fb42f8a1849e;hpb=69e14f75a4b031e489b7774914e5a176409cea78;p=ghc-hetmet.git diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index f1d29bd..8d8819a 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -5,42 +5,35 @@ \begin{code} module Rules ( - RuleBase, prepareRuleBase, lookupRule, - addIdSpecialisations, - ProtoCoreRule(..), pprProtoCoreRule, orphanRule + RuleBase, emptyRuleBase, + extendRuleBase, extendRuleBaseList, addRuleBaseFVs, + ruleBaseIds, ruleBaseFVs, + pprRuleBase, + + lookupRule, addRule, addIdSpecialisations ) where #include "HsVersions.h" import CoreSyn -- All of it -import OccurAnal ( occurAnalyseExpr, tagBinders, UsageDetails ) -import BinderInfo ( markMany ) -import CoreFVs ( exprFreeVars, idRuleVars, ruleSomeLhsFreeVars ) -import CoreUnfold ( Unfolding(..) ) -import CoreUtils ( whnfOrBottom, eqExpr ) +import OccurAnal ( occurAnalyseRule ) +import CoreFVs ( exprFreeVars, ruleRhsFreeVars, ruleSomeLhsFreeVars ) +import CoreUnfold ( isCheapUnfolding, unfoldingTemplate ) +import CoreUtils ( eqExpr ) import PprCore ( pprCoreRule ) -import Subst ( Subst, InScopeSet, substBndr, lookupSubst, extendSubst, - mkSubst, substEnv, setSubstEnv, - unBindSubst, bindSubstList, unBindSubstList, +import Subst ( Subst, InScopeSet, mkInScopeSet, lookupSubst, extendSubst, + substEnv, setSubstEnv, emptySubst, isInScope, + bindSubstList, unBindSubstList, substInScope, uniqAway ) -import Id ( Id, getIdUnfolding, - getIdSpecialisation, setIdSpecialisation, - setIdNoDiscard, maybeModifyIdInfo, modifyIdInfo - ) -import IdInfo ( zapLamIdInfo, setSpecInfo, specInfo ) -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 Type ( mkTyVarTy ) import qualified Unify ( match ) -import CmdLineOpts ( opt_D_dump_simpl, opt_D_verbose_core2core ) -import UniqFM -import ErrUtils ( dumpIfSet ) import Outputable import Maybes ( maybeToBool ) -import List ( partition ) import Util ( sortLt ) \end{code} @@ -87,7 +80,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 @@ -96,11 +89,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 -- @@ -115,16 +108,38 @@ 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. -- -- ASSUMPTION (A): --- No variable free in the template is bound in the target +-- A1. No top-level variable is bound in the target +-- A2. No template variable is bound in the target +-- A3. No lambda bound template variable is free in any subexpression of the target +-- +-- To see why A1 is necessary, consider matching +-- \x->f against \f->f +-- When we meet the lambdas we substitute [f/x] in the template (a no-op), +-- and then erroneously succeed in matching f against f. +-- +-- To see why A2 is needed consider matching +-- forall a. \b->b against \a->3 +-- When we meet the lambdas we substitute [a/b] in the template, and then +-- erroneously succeed in matching what looks like the template variable 'a' against 3. +-- +-- A3 is needed to validate the rule that says +-- (\x->E) matches F +-- if +-- (\x->E) matches (\x->F x) -matchRule in_scope (Rule rn tpl_vars tpl_args rhs) args - = go tpl_args args (mkSubst in_scope emptySubstEnv) + +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 tpl_var_set = mkVarSet tpl_vars @@ -133,12 +148,33 @@ 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 + 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. + + I now think this is probably a bad idea. + Should the template (map f xs) match (map g)? I think not. + For a start, in general eta expansion wastes work. + SLPJ July 99 + = case eta_complete tpl_args (mkVarSet leftovers) of Just leftovers' -> Just (rn, mkLams done (mkLams leftovers' rhs), mk_result_args subst done) @@ -168,30 +204,22 @@ 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 --- The *InScopeSet* in these Substs gives a superset of the free vars --- in the term being matched. This set can get augmented, for example --- when matching against a lambda: --- (\x.M) ~ N iff M ~ N x --- but we must clone x if it's already free in N +-- The *InScopeSet* in these Substs gives variables bound so far in the +-- target term. So when matching forall a. (\x. a x) against (\y. y y) +-- while processing the body of the lambdas, the in-scope set will be {y}. +-- That lets us do the occurs-check when matching 'a' against 'y' match :: CoreExpr -- Template -> CoreExpr -- Target @@ -201,8 +229,13 @@ match_fail = Nothing match (Var v1) e2 tpl_vars kont subst = case lookupSubst subst v1 of - Nothing | v1 `elemVarSet` tpl_vars -> kont (extendSubst subst v1 (DoneEx e2)) - -- v1 is a template variables + Nothing | v1 `elemVarSet` tpl_vars -- v1 is a template variable + -> if (any (`isInScope` subst) (varSetElems (exprFreeVars e2))) then + match_fail -- Occurs check failure + -- e.g. match forall a. (\x-> a x) against (\y. y y) + else + kont (extendSubst subst v1 (DoneEx e2)) + | eqExpr (Var v1) e2 -> kont subst -- v1 is not a template variable, so it must be a global constant @@ -211,9 +244,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 @@ -223,19 +256,25 @@ match (Lam x1 e1) (Lam x2 e2) tpl_vars kont subst -- This rule does eta expansion -- (\x.M) ~ N iff M ~ N x --- We must clone the binder in case it's already in scope in N +-- See assumption A3 match (Lam x1 e1) e2 tpl_vars kont subst - = match e1 (App e2 (mkVarArg x1')) tpl_vars kont' subst' - where - (subst', x1') = substBndr subst x1 - kont' subst = kont (unBindSubst subst x1 x1') + = bind [x1] [x1] (match e1 (App e2 (mkVarArg x1))) tpl_vars kont subst -- Eta expansion the other way -- M ~ (\y.N) iff \y.M y ~ \y.N -- 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 - = 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 @@ -274,12 +313,11 @@ match e1 (Let bind e2) tpl_vars kont subst -- (Its occurrence information is not necessarily up to date, -- so we don't use it.) match e1 (Var v2) tpl_vars kont subst - = case getIdUnfolding v2 of - CoreUnfolding form guidance unfolding - | whnfOrBottom form - -> match e1 unfolding tpl_vars kont subst + | isCheapUnfolding unfolding + = match e1 (unfoldingTemplate unfolding) tpl_vars kont subst + where + unfolding = idUnfolding v2 - other -> match_fail -- We can't cope with lets in the template @@ -310,7 +348,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) @@ -318,10 +356,11 @@ 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 - = case Unify.match ty1 ty2 tpl_vars Just (substEnv subst) of + = case Unify.match False {- for now: KSW 2000-10 -} ty1 ty2 tpl_vars Just (substEnv subst) of Nothing -> match_fail Just senv' -> kont (setSubstEnv subst senv') @@ -346,7 +385,7 @@ mkVarArg v | isId v = Var v %************************************************************************ \begin{code} -addRule :: Id -> CoreRules -> CoreRule -> CoreRules +addRule :: CoreRules -> Id -> CoreRule -> CoreRules -- 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. @@ -356,39 +395,40 @@ 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 str tpl_vars tpl_args rhs) - = Rules (insert rules) (rhs_fvs `unionVarSet` new_rhs_fvs) - where - new_rule = Rule str tpl_vars' tpl_args rhs' - -- Add occ info to tpl_vars, rhs - - (rhs_uds, rhs') = occurAnalyseExpr isLocallyDefined rhs - (rhs_uds1, tpl_vars') = tagBinders rhs_uds tpl_vars - - insert [] = [new_rule] - insert (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules) - | otherwise = rule : insert rules - - new_is_more_specific rule = maybeToBool (matchRule tpl_var_set rule tpl_args) - - tpl_var_set = mkVarSet tpl_vars' - -- Actually we should probably include the free vars of tpl_args, - -- but I can't be bothered +addRule (Rules rules rhs_fvs) id rule@(BuiltinRule _) + = Rules (rule:rules) rhs_fvs + -- Put it at the start for lack of anything better - new_rhs_fvs = (exprFreeVars rhs' `minusVarSet` tpl_var_set) `delVarSet` id +addRule (Rules rules rhs_fvs) id rule + = Rules (insertRule rules new_rule) (rhs_fvs `unionVarSet` new_rhs_fvs) + where + new_rule = occurAnalyseRule rule + new_rhs_fvs = ruleRhsFreeVars new_rule `delVarSet` id -- Hack alert! -- Don't include the Id in its own rhs free-var set. -- Otherwise the occurrence analyser makes bindings recursive -- that shoudn't be. E.g. -- RULE: f (f x y) z ==> f x (f y z) -addIdSpecialisations :: Id -> [([CoreBndr], [CoreExpr], CoreExpr)] -> Id -addIdSpecialisations id spec_stuff - = setIdSpecialisation id new_rules +insertRule rules new_rule@(Rule _ tpl_vars tpl_args _) + = go rules where - rule_name = _PK_ ("SPEC " ++ showSDoc (ppr id)) - new_rules = foldr add (getIdSpecialisation id) spec_stuff - add (vars, args, rhs) rules = addRule id rules (Rule rule_name vars args rhs) + tpl_var_set = mkInScopeSet (mkVarSet tpl_vars) + -- Actually we should probably include the free vars of tpl_args, + -- but I can't be bothered + + go [] = [new_rule] + 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) + +addIdSpecialisations :: Id -> [CoreRule] -> Id +addIdSpecialisations id rules + = setIdSpecialisation id new_specs + where + new_specs = foldr add (idSpecialisation id) rules + add rule rules = addRule rules id rule \end{code} @@ -399,26 +439,10 @@ addIdSpecialisations id spec_stuff %************************************************************************ \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 (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 - -orphanRule :: ProtoCoreRule -> Bool --- An "orphan rule" is one that is defined in this --- module, but of ran *imported* function. We need --- to track these separately when generating the interface file -orphanRule (ProtoCoreRule local fn _) - = local && not (isLocallyDefined fn) \end{code} @@ -429,58 +453,46 @@ orphanRule (ProtoCoreRule local fn _) %************************************************************************ \begin{code} -type RuleBase = (IdSet, -- Imported Ids that have rules attached - IdSet) -- Ids (whether local or imported) mentioned on +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 + + IdSet -- Ids (whether local or imported) mentioned on -- LHS of some rule; these should be black listed --- 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 + -- This representation is a bit cute, and I wonder if we should + -- change it to use (IdEnv CoreRule) which seems a bit more natural -prepareRuleBase :: [CoreBind] -> [ProtoCoreRule] -> ([CoreBind], RuleBase) -prepareRuleBase binds rules - = (map zap_bind binds, (imported_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_fvs is the set of all variables mentioned in 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) +ruleBaseIds (RuleBase ids _) = ids +ruleBaseFVs (RuleBase _ fvs) = fvs + +emptyRuleBase = RuleBase emptyVarSet emptyVarSet + +addRuleBaseFVs :: RuleBase -> IdSet -> RuleBase +addRuleBaseFVs (RuleBase rules fvs) extra_fvs + = RuleBase rules (fvs `unionVarSet` extra_fvs) + +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 rule_fvs) (id, rule) + = RuleBase (extendVarSet rule_ids new_id) + (rule_fvs `unionVarSet` extendVarSet lhs_fvs id) where - new_id = case lookupVarSet rule_id_set id of - Just id' -> addRuleToId id' rule - Nothing -> addRuleToId id rule + new_id = setIdSpecialisation id (addRule old_rules id rule) + old_rules = case lookupVarSet rule_ids id of + Nothing -> emptyCoreRules + Just id' -> idSpecialisation id' + lhs_fvs = ruleSomeLhsFreeVars isId rule -- Find *all* the free Ids of the LHS, not just -- locally defined ones!! -addRuleToId id rule = setIdSpecialisation id (addRule id (getIdSpecialisation id) rule) +pprRuleBase :: RuleBase -> SDoc +pprRuleBase (RuleBase rules _) = vcat [ pprCoreRule (ppr id) rs + | id <- varSetElems rules, + rs <- rulesRules $ idSpecialisation id ] \end{code} -