-- * Misc. CoreRule helpers
rulesOfBinds, getRules, pprRulesForUser,
- lookupRule, mkRule, mkLocalRule, roughTopNames
+ lookupRule, mkRule, roughTopNames
) where
#include "HsVersions.h"
Note [Overall plumbing for rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-* The ModGuts initially contains mg_rules :: [CoreRule] of rules
- declared in this module. During the core-to-core pipeline,
- locally-declared rules for locally-declared Ids are attached to the
- IdInfo for that Id, so the mg_rules field of ModGuts now only
- contains locally-declared rules for *imported* Ids. TidyPgm restores
- the original setup, so that the ModGuts again has *all* the
- locally-declared rules. See Note [Attach rules to local ids] in
- SimplCore
+* After the desugarer:
+ - The ModGuts initially contains mg_rules :: [CoreRule] of
+ locally-declared rules for imported Ids.
+ - Locally-declared rules for locally-declared Ids are attached to
+ the IdInfo for that Id. See Note [Attach rules to local ids] in
+ DsBinds
+
+* TidyPgm strips off all the rules from local Ids and adds them to
+ mg_rules, so that the ModGuts has *all* the locally-declared rules.
* The HomePackageTable contains a ModDetails for each home package
module. Each contains md_rules :: [CoreRule] of rules declared in
The HomePackageTable doesn't have a single RuleBase because technically
we should only be able to "see" rules "below" this module; so we
generate a RuleBase for (c) by combing rules from all the modules
- "below" us. That's whye we can't just select the home-package RuleBase
+ "below" us. That's why we can't just select the home-package RuleBase
from HscEnv.
[NB: we are inconsistent here. We should do the same for external
where pi' :: Lift Int# is the specialised version of pi.
\begin{code}
-mkLocalRule :: RuleName -> Activation
- -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
--- ^ Used to make 'CoreRule' for an 'Id' defined in the module being
--- compiled. See also 'CoreSyn.CoreRule'
-mkLocalRule = mkRule True
-
-mkRule :: Bool -> RuleName -> Activation
+mkRule :: Bool -> Bool -> RuleName -> Activation
-> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being
-- compiled. See also 'CoreSyn.CoreRule'
-mkRule is_local name act fn bndrs args rhs
+mkRule is_auto is_local name act fn bndrs args rhs
= Rule { ru_name = name, ru_fn = fn, ru_act = act,
ru_bndrs = bndrs, ru_args = args,
ru_rhs = occurAnalyseExpr rhs,
ru_rough = roughTopNames args,
- ru_local = is_local }
+ ru_auto = is_auto, ru_local = is_local }
--------------
roughTopNames :: [CoreExpr] -> [Maybe Name]
(fn,args) = target
isMoreSpecific :: CoreRule -> CoreRule -> Bool
-isMoreSpecific (BuiltinRule {}) _ = True
-isMoreSpecific _ (BuiltinRule {}) = False
+-- This tests if one rule is more specific than another
+-- We take the view that a BuiltinRule is less specific than
+-- anything else, because we want user-define rules to "win"
+-- In particular, class ops have a built-in rule, but we
+-- any user-specific rules to win
+-- eg (Trac #4397)
+-- truncate :: (RealFrac a, Integral b) => a -> b
+-- {-# RULES "truncate/Double->Int" truncate = double2Int #-}
+-- double2Int :: Double -> Int
+-- We want the specific RULE to beat the built-in class-op rule
+isMoreSpecific (BuiltinRule {}) _ = False
+isMoreSpecific (Rule {}) (BuiltinRule {}) = True
isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 })
(Rule { ru_bndrs = bndrs2, ru_args = args2 })
= isJust (matchN id_unfolding_fun in_scope bndrs2 args2 args1)
-> [Var] -- ^ Match template type variables
-> [CoreExpr] -- ^ Match template
-> [CoreExpr] -- ^ Target; can have more elements than the template
- -> Maybe (BindWrapper, -- ^ Floated bindings; see Note [Matching lets]
+ -> Maybe (BindWrapper, -- Floated bindings; see Note [Matching lets]
[CoreExpr])
-- For a given match template and context, find bindings to wrap around
-- the entire result and what should be substituted for each template variable.
lookup_tmpl :: TvSubstEnv -> IdSubstEnv -> Var -> CoreExpr
lookup_tmpl tv_subst id_subst tmpl_var'
- | isTyVar tmpl_var' = case lookupVarEnv tv_subst tmpl_var' of
+ | isTyCoVar tmpl_var' = case lookupVarEnv tv_subst tmpl_var' of
Just ty -> Type ty
Nothing -> unbound tmpl_var'
| otherwise = case lookupVarEnv id_subst tmpl_var' of
match idu menv subst (Lam x1 e1) e2
= match idu menv' subst e1 (App e2 (varToCoreExpr new_x))
where
- (rn_env', new_x) = rnBndrL (me_env menv) x1
+ (rn_env', new_x) = rnEtaL (me_env menv) x1
menv' = menv { me_env = rn_env' }
-- Eta expansion the other way
match idu menv subst e1 (Lam x2 e2)
= match idu menv' subst (App e1 (varToCoreExpr new_x)) e2
where
- (rn_env', new_x) = rnBndrR (me_env menv) x2
+ (rn_env', new_x) = rnEtaR (me_env menv) x2
menv' = menv { me_env = rn_env' }
match idu menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
match_alts _ _ _ _ _
= Nothing
-\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 :: MatchEnv
-> SubstEnv
-> Type -- Template
-> Type -- Target
-> Maybe SubstEnv
+-- 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).
+
match_ty menv (tv_subst, id_subst, binds) ty1 ty2
= do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2
; return (tv_subst', id_subst, binds) }
projects / ghc-hetmet.git / blobdiff