mkSpecInfo, extendSpecInfo, addSpecInfo,
rulesOfBinds, addIdSpecialisations,
+
+ matchN,
lookupRule, mkLocalRule, roughTopNames
) where
import CoreUtils ( tcEqExprX )
import PprCore ( pprRules )
import Type ( TvSubstEnv )
+import Coercion ( coercionKind )
import TcType ( tcSplitTyConApp_maybe )
import CoreTidy ( tidyRules )
import Id ( Id, idUnfolding, isLocalId, isGlobalId, idName,
emptyVarEnv, lookupVarEnv, extendVarEnv,
nukeRnEnvL, mkRnEnv2, rnOccR, rnOccL, inRnEnvR,
rnBndrR, rnBndr2, rnBndrL, rnBndrs2,
- rnInScope, extendRnInScopeList )
+ rnInScope, extendRnInScopeList, lookupRnInScope )
import VarSet
import Name ( Name, NamedThing(..), nameOccName )
import NameEnv
import Maybes ( isJust, orElse )
import OrdList
import Bag
-import Util ( singleton, mapAccumL )
+import Util ( singleton )
import List ( isPrefixOf )
\end{code}
findBest target (rule,ans) [] = (rule,ans)
findBest target (rule1,ans1) ((rule2,ans2):prs)
| rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs
- | rule2 `isMoreSpecific` rule1 = findBest target (rule1,ans1) prs
+ | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs
#ifdef DEBUG
| otherwise = pprTrace "Rules.findBest: rule overlap (Rule 1 wins)"
(vcat [ptext SLIT("Expression to match:") <+> ppr fn <+> sep (map ppr args),
-- from nested matches; see the Let case of match, below
--
type SubstEnv = (TvSubstEnv, IdSubstEnv, OrdList CoreBind)
-type IdSubstEnv = IdEnv CoreExpr
+type IdSubstEnv = IdEnv CoreExpr
emptySubstEnv :: SubstEnv
emptySubstEnv = (emptyVarEnv, emptyVarEnv, nilOL)
-- (Its occurrence information is not necessarily up to date,
-- so we don't use it.)
match menv subst e1 (Var v2)
- | isCheapUnfolding unfolding
+ | not (inRnEnvR rn_env v2),
+ -- If v2 is in the RnEnvR, then it's locally bound and can't
+ -- have an unfolding. We must make this check because if it
+ -- is locally bound we must not look it up in the in-scope set
+ -- E.g. (\x->x) where x is already in scope
+ isCheapUnfolding unfolding
= match menv subst e1 (unfoldingTemplate unfolding)
where
- unfolding = idUnfolding v2
+ rn_env = me_env menv
+ unfolding = idUnfolding (lookupRnInScope rn_env v2)
+ -- Notice that we look up v2 in the in-scope set
+ -- See Note [Lookup in-scope]
+
+-- Matching a let-expression. Consider
+-- RULE forall x. f (g x) = <rhs>
+-- and target expression
+-- f (let { w=R } in g E))
+-- Then we'd like the rule to match, to generate
+-- let { w=R } in (\x. <rhs>) E
+-- In effect, we want to float the let-binding outward, to enable
+-- the match to happen. This is the WHOLE REASON for accumulating
+-- bindings in the SubstEnv
+--
+-- We can only do this if
+-- (a) Widening the scope of w does not capture any variables
+-- We use a conservative test: w is not already in scope
+-- (b) The free variables of R are not bound by the part of the
+-- target expression outside the let binding; e.g.
+-- f (\v. let w = v+1 in g E)
+-- Here we obviously cannot float the let-binding for w.
+
+match menv subst@(tv_subst, id_subst, binds) e1 (Let bind e2)
+ | all freshly_bound bndrs,
+ not (any locally_bound bind_fvs)
+ = match (menv { me_env = rn_env' })
+ (tv_subst, id_subst, binds `snocOL` bind)
+ e1 e2
+ where
+ rn_env = me_env menv
+ bndrs = bindersOf bind
+ bind_fvs = varSetElems (bindFreeVars bind)
+ freshly_bound x = not (x `rnInScope` rn_env)
+ locally_bound x = inRnEnvR rn_env x
+ rn_env' = extendRnInScopeList rn_env bndrs
match menv subst (Lit lit1) (Lit lit2)
| lit1 == lit2
-- This rule does eta expansion
-- (\x.M) ~ N iff M ~ N x
+-- It's important that this is *after* the let rule,
+-- so that (\x.M) ~ (let y = e in \y.N)
+-- does the let thing, and then gets the lam/lam rule above
match menv subst (Lam x1 e1) e2
= match menv' subst e1 (App e2 (varToCoreExpr new_x))
where
match menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
= do { subst1 <- match_ty menv subst ty1 ty2
; subst2 <- match menv subst1 e1 e2
- ; let menv' = menv { me_env = rnBndr2 (me_env menv) x2 x2 }
+ ; let menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 }
; match_alts menv' subst2 alts1 alts2 -- Alts are both sorted
}
match menv subst (Type ty1) (Type ty2)
= match_ty menv subst ty1 ty2
-match menv subst (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2)
+match menv subst (Cast e1 co1) (Cast e2 co2)
+ | (from1, to1) <- coercionKind co1
+ , (from2, to2) <- coercionKind co2
= do { subst1 <- match_ty menv subst to1 to2
; subst2 <- match_ty menv subst1 from1 from2
; match menv subst2 e1 e2 }
--- Matching a let-expression. Consider
--- RULE forall x. f (g x) = <rhs>
--- and target expression
--- f (let { w=R } in g E))
--- Then we'd like the rule to match, to generate
--- let { w=R } in (\x. <rhs>) E
--- In effect, we want to float the let-binding outward, to enable
--- the match to happen. This is the WHOLE REASON for accumulating
--- bindings in the SubstEnv
---
--- We can only do this if
--- (a) Widening the scope of w does not capture any variables
--- We use a conservative test: w is not already in scope
--- (b) The free variables of R are not bound by the part of the
--- target expression outside the let binding; e.g.
--- f (\v. let w = v+1 in g E)
--- Here we obviously cannot float the let-binding for w.
-
-match menv subst@(tv_subst, id_subst, binds) e1 (Let bind e2)
- | all freshly_bound bndrs,
- not (any locally_bound bind_fvs)
- = match (menv { me_env = rn_env' })
- (tv_subst, id_subst, binds `snocOL` bind)
- e1 e2
- where
- rn_env = me_env menv
- bndrs = bindersOf bind
- bind_fvs = varSetElems (bindFreeVars bind)
- freshly_bound x = not (x `rnInScope` rn_env)
- locally_bound x = inRnEnvR rn_env x
- rn_env' = extendRnInScopeList rn_env bndrs
-
+{- REMOVING OLD CODE: I think that the above handling for let is
+ better than the stuff here, which looks
+ pretty suspicious to me. SLPJ Sept 06
-- This is an interesting rule: we simply ignore lets in the
-- term being matched against! The unfolding inside it is (by assumption)
-- already inside any occurrences of the bound variables, so we'll expand
-- We must not get success with x->y! So we record that y is
-- locally bound (with rnBndrR), and proceed. The Var case
-- will fail when trying to bind x->y
- --
+-}
-- Everything else fails
match menv subst e1 e2 = Nothing
-> Nothing -- Occurs check failure
-- e.g. match forall a. (\x-> a x) against (\y. y y)
- | otherwise
+ | otherwise -- No renaming to do on e2
-> Just (tv_subst, extendVarEnv id_subst v1 e2, binds)
Just e2' | tcEqExprX (nukeRnEnvL rn_env) e2' e2
\end{code}
+Note [Lookup in-scope]
+~~~~~~~~~~~~~~~~~~~~~~
+Consider this example
+ foo :: Int -> Maybe Int -> Int
+ foo 0 (Just n) = n
+ foo m (Just n) = foo (m-n) (Just n)
+
+SpecConstr sees this fragment:
+
+ case w_smT of wild_Xf [Just A] {
+ Data.Maybe.Nothing -> lvl_smf;
+ Data.Maybe.Just n_acT [Just S(L)] ->
+ case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] ->
+ $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
+ }};
+
+and correctly generates the rule
+
+ RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int#
+ sc_snn :: GHC.Prim.Int#}
+ $wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr))
+ = $s$wfoo_sno y_amr sc_snn ;]
+
+BUT we must ensure that this rule matches in the original function!
+Note that the call to $wfoo is
+ $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
+
+During matching we expand wild_Xf to (Just n_acT). But then we must also
+expand n_acT to (I# y_amr). And we can only do that if we look up n_acT
+in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding
+at all.
+
+That is why the 'lookupRnInScope' call in the (Var v2) case of 'match'
+is so important.
+
+
%************************************************************************
%* *
\subsection{Checking a program for failing rule applications}
ruleCheck env (Type ty) = emptyBag
ruleCheck env (App f a) = ruleCheckApp env (App f a) []
ruleCheck env (Note n e) = ruleCheck env e
+ruleCheck env (Cast e co) = ruleCheck env e
ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e
ruleCheck env (Lam b e) = ruleCheck env e
ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`
projects / ghc-hetmet.git / blobdiff