\begin{code}
module Rules (
- RuleBase, emptyRuleBase, extendRuleBase, extendRuleBaseList,
- prepareLocalRuleBase, prepareOrphanRuleBase,
- unionRuleBase, lookupRule, addRule, addIdSpecialisations,
- ProtoCoreRule(..), pprProtoCoreRule, pprRuleBase,
- localRule, orphanRule
+ RuleBase, emptyRuleBase,
+ extendRuleBase, extendRuleBaseList, addRuleBaseFVs,
+ ruleBaseIds, ruleBaseFVs,
+ pprRuleBase,
+
+ lookupRule, addRule, addIdSpecialisations
) where
#include "HsVersions.h"
import CoreSyn -- All of it
import OccurAnal ( occurAnalyseRule )
-import CoreFVs ( exprFreeVars, idRuleVars, ruleRhsFreeVars, ruleSomeLhsFreeVars )
+import CoreFVs ( exprFreeVars, ruleRhsFreeVars, ruleLhsFreeIds )
import CoreUnfold ( isCheapUnfolding, unfoldingTemplate )
import CoreUtils ( eqExpr )
import PprCore ( pprCoreRule )
substEnv, setSubstEnv, emptySubst, isInScope,
bindSubstList, unBindSubstList, substInScope, uniqAway
)
-import Id ( Id, idUnfolding, zapLamIdInfo,
- idSpecialisation, setIdSpecialisation,
- setIdNoDiscard
- )
-import Name ( isLocallyDefined )
-import Var ( isTyVar, isId )
+import Id ( Id, idUnfolding, idSpecialisation, setIdSpecialisation )
+import Var ( isId )
import VarSet
import VarEnv
-import Type ( mkTyVarTy )
-import qualified Unify ( match )
+import TcType ( mkTyVarTy )
+import qualified TcType ( match )
+import TypeRep ( Type(..) ) -- Can see type representation for matching
-import UniqFM
import Outputable
-import Maybes ( maybeToBool )
+import Maybe ( isJust, isNothing, fromMaybe )
import Util ( sortLt )
\end{code}
mk_result_args subst done)
Nothing -> Nothing -- Failure
where
- (done, leftovers) = partition (\v -> maybeToBool (lookupSubstEnv subst_env v))
+ (done, leftovers) = partition (\v -> isJust (lookupSubstEnv subst_env v))
(map zapOccInfo tpl_vars)
-- Zap the occ info
subst_env = substEnv subst
Nothing -> Nothing
eta_complete other vars = Nothing
--}
zapOccInfo bndr | isTyVar bndr = bndr
| otherwise = zapLamIdInfo bndr
+-}
\end{code}
\begin{code}
kont (extendSubst subst v1 (DoneEx e2))
- | eqExpr (Var v1) e2 -> kont subst
+ | eqExpr (Var v1) e2 -> kont subst
-- v1 is not a template variable, so it must be a global constant
- Just (DoneEx e2') | eqExpr e2' e2 -> kont subst
+ Just (DoneEx e2') | eqExpr e2' e2 -> kont subst
other -> match_fail
subst' = bindSubstList subst vs1 vs2
-- The unBindSubst relies on no shadowing in the template
- not_in_subst v = not (maybeToBool (lookupSubst subst v))
+ not_in_subst v = isNothing (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
- Nothing -> match_fail
- Just senv' -> kont (setSubstEnv subst senv')
-
-----------------------------------------
matches [] [] tpl_vars kont subst
= kont subst
matches (e:es) (e':es') tpl_vars kont subst
| otherwise = Type (mkTyVarTy v)
\end{code}
+Matching Core types: use the matcher in TcType.
+Notice that we treat newtypes as opaque. For example, suppose
+we have a specialised version of a function at a newtype, say
+ newtype T = MkT Int
+We only want to replace (f T) with f', not (f Int).
+
+\begin{code}
+----------------------------------------
+match_ty ty1 ty2 tpl_vars kont subst
+ = TcType.match ty1 ty2 tpl_vars kont' (substEnv subst)
+ where
+ kont' senv = kont (setSubstEnv subst senv)
+\end{code}
+
+
+
%************************************************************************
%* *
\subsection{Adding a new rule}
%************************************************************************
\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
+addRule (Rules rules rhs_fvs) id rule
= Rules (insertRule rules new_rule) (rhs_fvs `unionVarSet` new_rhs_fvs)
where
new_rule = occurAnalyseRule 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)
+ new_is_more_specific rule = isJust (matchRule tpl_var_set rule tpl_args)
-addIdSpecialisations :: Id -> [([CoreBndr], [CoreExpr], CoreExpr)] -> Id
-addIdSpecialisations id spec_stuff
- = setIdSpecialisation id new_rules
+addIdSpecialisations :: Id -> [CoreRule] -> Id
+addIdSpecialisations id rules
+ = setIdSpecialisation id new_specs
where
- rule_name = _PK_ ("SPEC " ++ showSDoc (ppr id))
- new_rules = foldr add (idSpecialisation id) spec_stuff
- add (vars, args, rhs) rules = addRule id rules (Rule rule_name vars args rhs)
+ 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 (ppr fn) rule
-
lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
lookupRule in_scope fn args
= 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 for an *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}
-data RuleBase = RuleBase (IdEnv CoreRules) -- Maps an Id to its rules
- IdSet -- Ids (whether local or imported) mentioned on
- -- LHS of some rule; these should be black listed
+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
+
+ -- This representation is a bit cute, and I wonder if we should
+ -- change it to use (IdEnv CoreRule) which seems a bit more natural
+
+ruleBaseIds (RuleBase ids _) = ids
+ruleBaseFVs (RuleBase _ fvs) = fvs
+
+emptyRuleBase = RuleBase emptyVarSet emptyVarSet
-emptyRuleBase = RuleBase emptyVarEnv emptyVarSet
+addRuleBaseFVs :: RuleBase -> IdSet -> RuleBase
+addRuleBaseFVs (RuleBase rules fvs) extra_fvs
+ = RuleBase rules (fvs `unionVarSet` extra_fvs)
-extendRuleBaseList :: RuleBase -> [(Name,CoreRule)] -> RuleBase
+extendRuleBaseList :: RuleBase -> [(Id,CoreRule)] -> RuleBase
extendRuleBaseList rule_base new_guys
- = foldr extendRuleBase rule_base new_guys
+ = foldl extendRuleBase rule_base new_guys
-extendRuleBase :: RuleBase -> (Name,CoreRule) -> RuleBase
-extendRuleBase (RuleBase rule_env rule_fvs) (id, rule)
- = RuleBase (extendVarEnv rule_env id (addRule id rules_for_id rule))
+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
- rules_for_id = case lookupWithDefaultVarEnv rule_env emptyCoreRules id
+ new_id = setIdSpecialisation id (addRule old_rules id rule)
- lhs_fvs = ruleSomeLhsFreeVars isId rule
- -- Find *all* the free Ids of the LHS, not just
- -- locally defined ones!!
+ old_rules = idSpecialisation (fromMaybe id (lookupVarSet rule_ids id))
+ -- Get the old rules from rule_ids if the Id is already there, but
+ -- if not, use the Id from the incoming rule. If may be a PrimOpId,
+ -- in which case it may have rules in its belly already. Seems
+ -- dreadfully hackoid.
-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
+ lhs_fvs = ruleLhsFreeIds rule
+ -- Finds *all* the free Ids of the LHS, not just
+ -- locally defined ones!!
pprRuleBase :: RuleBase -> SDoc
-pprRuleBase (rules,_) = vcat [ pprCoreRule (ppr id) rs
- | id <- varSetElems rules,
- rs <- rulesRules $ idSpecialisation id ]
-
--- 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
-
-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 emptyRuleBase local_rules
- imported_id_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids
-
- -- 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.
- -- - 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
-
-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
+pprRuleBase (RuleBase rules _) = vcat [ pprCoreRule (ppr id) rs
+ | id <- varSetElems rules,
+ rs <- rulesRules $ idSpecialisation id ]
\end{code}
projects / ghc-hetmet.git / blobdiff