\begin{code}
module Rules (
- RuleBase, prepareRuleBase, lookupRule, addRule,
- 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 Const ( Con(..), Literal(..) )
-import OccurAnal ( occurAnalyseExpr, tagBinders, UsageDetails )
-import BinderInfo ( markMany )
-import CoreFVs ( exprFreeVars, idRuleVars, ruleSomeLhsFreeVars )
+import OccurAnal ( occurAnalyseRule )
+import CoreFVs ( exprFreeVars, ruleRhsFreeVars, ruleSomeLhsFreeVars )
import CoreUnfold ( isCheapUnfolding, unfoldingTemplate )
-import CoreUtils ( eqExpr, cheapEqExpr )
+import CoreUtils ( eqExpr )
import PprCore ( pprCoreRule )
-import Subst ( Subst, InScopeSet, substBndr, lookupSubst, extendSubst,
- mkSubst, substEnv, setSubstEnv, emptySubst, isInScope,
- unBindSubst, bindSubstList, unBindSubstList, substInScope
+import Subst ( Subst, InScopeSet, mkInScopeSet, lookupSubst, extendSubst,
+ substEnv, setSubstEnv, emptySubst, isInScope,
+ bindSubstList, unBindSubstList, substInScope, uniqAway
)
-import Id ( Id, getIdUnfolding, zapLamIdInfo,
- getIdSpecialisation, setIdSpecialisation,
- setIdNoDiscard, maybeModifyIdInfo, modifyIdInfo
- )
-import IdInfo ( 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}
Nothing -> Nothing
eta_complete other vars = Nothing
--}
zapOccInfo bndr | isTyVar bndr = 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
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
| 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
----------------------------------------
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')
%************************************************************************
\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.
-- 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 _)
+addRule (Rules rules rhs_fvs) id 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)
+addRule (Rules rules rhs_fvs) id rule
+ = Rules (insertRule rules new_rule) (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
-
- new_rhs_fvs = (exprFreeVars rhs' `minusVarSet` tpl_var_set) `delVarSet` id
+ 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}
%************************************************************************
\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 (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}
%************************************************************************
\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 all_rules
- = (map zap_bind binds, (imported_rule_ids, rule_lhs_fvs))
- where
- (rule_ids, rule_lhs_fvs) = foldr add_rule (emptyVarSet, emptyVarSet) all_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}