\begin{code}
module Rules (
RuleBase, emptyRuleBase,
- extendRuleBase, extendRuleBaseList, addRuleBaseFVs,
- ruleBaseIds, ruleBaseFVs,
+ extendRuleBaseList,
+ ruleBaseIds, getLocalRules,
pprRuleBase, ruleCheckProgram,
lookupRule, addRule, addIdSpecialisations
import CoreSyn -- All of it
import OccurAnal ( occurAnalyseRule )
-import CoreFVs ( exprFreeVars, ruleRhsFreeVars, ruleLhsFreeIds )
+import CoreFVs ( exprFreeVars, ruleRhsFreeVars )
import CoreUnfold ( isCheapUnfolding, unfoldingTemplate )
import CoreUtils ( eqExpr )
-import PprCore ( pprCoreRule )
+import CoreTidy ( pprTidyIdRules )
import Subst ( Subst, InScopeSet, mkInScopeSet, lookupSubst, extendSubst,
substEnv, setSubstEnv, emptySubst, isInScope, emptyInScopeSet,
bindSubstList, unBindSubstList, substInScope, uniqAway
)
-import Id ( Id, idUnfolding, idSpecialisation, setIdSpecialisation )
+import Id ( Id, idIsFrom, idUnfolding, idSpecialisation, setIdSpecialisation )
import Var ( isId )
import VarSet
import VarEnv
import TcType ( mkTyVarTy )
import qualified TcType ( match )
import BasicTypes ( Activation, CompilerPhase, isActive )
+import Module ( Module )
import Outputable
+import FastString
import Maybe ( isJust, isNothing, fromMaybe )
import Util ( sortLt )
import Bag
-import List ( isPrefixOf )
+import List ( isPrefixOf, partition )
\end{code}
bug_msg = sep [ppr vs1, ppr vs2]
----------------------------------------
-matches [] [] tpl_vars kont subst
- = kont subst
-matches (e:es) (e':es') tpl_vars kont subst
- = match e e' tpl_vars (matches es es' tpl_vars kont) subst
-matches es es' tpl_vars kont subst
- = match_fail
-
-----------------------------------------
mkVarArg :: CoreBndr -> CoreArg
mkVarArg v | isId v = Var v
| otherwise = Type (mkTyVarTy v)
where
name_match_rules = case idSpecialisation fn of
Rules rules _ -> filter match rules
- match rule = pat `isPrefixOf` _UNPK_ (ruleName rule)
+ match rule = pat `isPrefixOf` unpackFS (ruleName rule)
ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
ruleAppCheck_help phase fn args rules
check_rule rule = rule_herald rule <> colon <+> rule_info rule
- rule_herald (BuiltinRule name _) = text "Builtin rule" <+> doubleQuotes (ptext name)
- rule_herald (Rule name _ _ _ _) = text "Rule" <+> doubleQuotes (ptext name)
+ rule_herald (BuiltinRule name _) =
+ ptext SLIT("Builtin rule") <+> doubleQuotes (ftext name)
+ rule_herald (Rule name _ _ _ _) =
+ ptext SLIT("Rule") <+> doubleQuotes (ftext name)
rule_info rule
| Just (name,_) <- matchRule noBlackList emptyInScopeSet rule args
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
-
-addRuleBaseFVs :: RuleBase -> IdSet -> RuleBase
-addRuleBaseFVs (RuleBase rules fvs) extra_fvs
- = RuleBase rules (fvs `unionVarSet` extra_fvs)
+ruleBaseIds (RuleBase ids) = ids
+emptyRuleBase = RuleBase emptyVarSet
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)
+extendRuleBase (RuleBase rule_ids) (id, rule)
= RuleBase (extendVarSet rule_ids new_id)
- (rule_fvs `unionVarSet` extendVarSet lhs_fvs id)
where
- new_id = setIdSpecialisation id (addRule id old_rules rule)
-
+ new_id = setIdSpecialisation id (addRule id old_rules rule)
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.
- lhs_fvs = ruleLhsFreeIds rule
- -- Finds *all* the free Ids of the LHS, not just
- -- locally defined ones!!
+getLocalRules :: Module -> RuleBase -> (IdSet, -- Ids with local rules
+ RuleBase) -- Non-local rules
+-- Get the rules for locally-defined Ids out of the RuleBase
+-- If we miss any rules for Ids defined here, then we end up
+-- giving the local decl a new Unique (because the in-scope-set is (hackily) the
+-- same as the non-local-rule-id set, so the Id looks as if it's in scope
+-- and hence should be cloned), and now the binding for the class method
+-- doesn't have the same Unique as the one in the Class and the tc-env
+-- Example: class Foo a where
+-- op :: a -> a
+-- {-# RULES "op" op x = x #-}
+--
+-- NB we can't use isLocalId, because isLocalId isn't true of class methods.
+getLocalRules this_mod (RuleBase ids)
+ = (mkVarSet local_ids, RuleBase (mkVarSet imp_ids))
+ where
+ (local_ids, imp_ids) = partition (idIsFrom this_mod) (varSetElems ids)
pprRuleBase :: RuleBase -> SDoc
-pprRuleBase (RuleBase rules _) = vcat [ pprCoreRule (ppr id) rs
- | id <- varSetElems rules,
- rs <- rulesRules $ idSpecialisation id ]
+pprRuleBase (RuleBase rules) = vcat [ pprTidyIdRules id | id <- varSetElems rules ]
\end{code}
projects / ghc-hetmet.git / blobdiff