import CoreSyn -- All of it
import OccurAnal ( occurAnalyseRule )
-import CoreFVs ( exprFreeVars, ruleRhsFreeVars, ruleSomeLhsFreeVars )
+import CoreFVs ( exprFreeVars, ruleRhsFreeVars, ruleLhsFreeIds )
import CoreUnfold ( isCheapUnfolding, unfoldingTemplate )
import CoreUtils ( eqExpr )
import PprCore ( pprCoreRule )
import Var ( isId )
import VarSet
import VarEnv
-import Type ( mkTyVarTy )
-import qualified Unify ( match )
+import TcType ( mkTyVarTy )
+import qualified TcType ( match )
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
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 False {- for now: KSW 2000-10 -} 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}
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 rules id (Rule rule_name vars args rhs)
+ new_specs = foldr add (idSpecialisation id) rules
+ add rule rules = addRule rules id rule
\end{code}
-- 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
+ 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
(rule_fvs `unionVarSet` extendVarSet lhs_fvs id)
where
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
+
+ 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!!
pprRuleBase :: RuleBase -> SDoc