diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs
index 596d9824db03763604a2211932e6674239bdf714..e72003d60b718f7f66fd7b310bb7b3ceab2e19a5 100644
--- a/compiler/GHC/Core/Opt/Simplify/Env.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Env.hs
@@ -1237,9 +1237,8 @@ See also Note [Return type for join points] and Note [Join points and case-of-ca
-}
getSubst :: SimplEnv -> Subst
-getSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env
- , seCvSubst = cv_env })
- = mkSubst in_scope tv_env cv_env emptyIdSubstEnv
+getSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env })
+ = mkTCvSubst in_scope tv_env cv_env
substTy :: HasDebugCallStack => SimplEnv -> Type -> Type
substTy env ty = Type.substTy (getSubst env) ty
diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs
index 09460812a435af119d5dfb526b0e3586011533f6..16cca77553fec8209b0ba3758f065ad78bab10a8 100644
--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ b/compiler/GHC/Core/Opt/SpecConstr.hs
@@ -81,8 +81,8 @@ import GHC.Builtin.Names ( specTyConKey )
import GHC.Exts( SpecConstrAnnotation(..) )
import GHC.Serialized ( deserializeWithData )
-import Control.Monad ( zipWithM )
-import Data.List (nubBy, sortBy, partition, dropWhileEnd, mapAccumL )
+import Control.Monad
+import Data.List ( sortBy, partition, dropWhileEnd, mapAccumL )
import Data.Maybe( mapMaybe )
import Data.Ord( comparing )
import Data.Tuple
@@ -2381,19 +2381,23 @@ callsToNewPats :: ScEnv -> Id
-- The "New" in the name means "patterns that are not already covered
-- by an existing specialisation"
callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls
- = do { mb_pats <- mapM (callToPats env bndr_occs) calls
+ = do { mb_pats <- mapM (callToPat env bndr_occs) calls
; let have_boring_call = any isNothing mb_pats
good_pats :: [CallPat]
good_pats = catMaybes mb_pats
+ in_scope = getSubstInScope (sc_subst env)
+
-- Remove patterns we have already done
new_pats = filterOut is_done good_pats
- is_done p = any (samePat p . os_pat) done_specs
+ is_done p = any is_better done_specs
+ where
+ is_better done = betterPat in_scope (os_pat done) p
-- Remove duplicates
- non_dups = nubBy samePat new_pats
+ non_dups = subsumePats in_scope new_pats
-- Remove ones that have too many worker variables
small_pats = filterOut too_many_worker_args non_dups
@@ -2410,6 +2414,10 @@ callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls
(pats_were_discarded, trimmed_pats) = trim_pats env fn spec_info small_pats
-- ; pprTraceM "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls
+-- , text "good_pats:" <+> ppr good_pats
+-- , text "new_pats:" <+> ppr new_pats
+-- , text "non_dups:" <+> ppr non_dups
+-- , text "small_pats:" <+> ppr small_pats
-- , text "done_specs:" <+> ppr (map os_pat done_specs)
-- , text "trimmed_pats:" <+> ppr trimmed_pats ])
@@ -2790,40 +2798,69 @@ valueIsWorkFree :: Value -> Bool
valueIsWorkFree LambdaVal = True
valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args
-samePat :: CallPat -> CallPat -> Bool
-samePat (CP { cp_qvars = vs1, cp_args = as1 })
- (CP { cp_qvars = vs2, cp_args = as2 })
- = all2 same as1 as2
+betterPat :: InScopeSet -> CallPat -> CallPat -> Bool
+-- pat1 f @a (Just @a (x::a))
+-- is better than
+-- pat2 f @Int (Just @Int (x::Int))
+-- That is, we can instantiate pat1 to get pat2
+-- See Note [Pattern duplicate elimination]
+betterPat is (CP { cp_qvars = vs1, cp_args = as1 })
+ (CP { cp_qvars = vs2, cp_args = as2 })
+ = case matchExprs ise vs1 as1 as2 of
+ Just (_, ms) -> all exprIsTrivial ms
+ Nothing -> False
+ where
+ ise = ISE (is `extendInScopeSetList` vs2) (const noUnfolding)
+
+subsumePats :: InScopeSet -> [CallPat] -> [CallPat]
+-- Remove any patterns subsumed by others
+-- See Note [Pattern duplicate elimination]
+subsumePats is pats = foldr add [] pats
where
- -- If the args are the same, their strictness marks will be too so we don't compare those.
- same (Var v1) (Var v2)
- | v1 `elem` vs1 = v2 `elem` vs2
- | v2 `elem` vs2 = False
- | otherwise = v1 == v2
-
- same (Lit l1) (Lit l2) = l1==l2
- same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
-
- same (Type {}) (Type {}) = True -- Note [Ignore type differences]
- same (Coercion {}) (Coercion {}) = True
- same (Tick _ e1) e2 = same e1 e2 -- Ignore casts and notes
- same (Cast e1 _) e2 = same e1 e2
- same e1 (Tick _ e2) = same e1 e2
- same e1 (Cast e2 _) = same e1 e2
-
- same e1 e2 = warnPprTrace (bad e1 || bad e2) "samePat" (ppr e1 $$ ppr e2) $
- False -- Let, lambda, case should not occur
- bad (Case {}) = True
- bad (Let {}) = True
- bad (Lam {}) = True
- bad _other = False
+ add :: CallPat -> [CallPat] -> [CallPat]
+ add ci [] = [ci]
+ add ci1 (ci2:cis) | betterPat is ci2 ci1 = ci2:cis
+ | betterPat is ci1 ci2 = ci1:cis
+ | otherwise = ci2 : add ci1 cis
{-
-Note [Ignore type differences]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We do not want to generate specialisations where the call patterns
-differ only in their type arguments! Not only is it utterly useless,
-but it also means that (with polymorphic recursion) we can generate
-an infinite number of specialisations. Example is Data.Sequence.adjustTree,
-I think.
+Note [Pattern duplicate elimination]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider f :: (a,a) -> blah, and two calls
+ f @Int (x,y)
+ f @Bool (p,q)
+
+The danger is that we'll generate two *essentially identical* specialisations,
+both for pairs, but with different types instantiating `a` (see #24229).
+
+But we'll only make a `CallPat` for an argument (a,b) if `foo` scrutinises
+that argument. So SpecConstr should never need to specialise f's polymorphic
+type arguments. Even with only one of these calls we should be able to
+generalise to the `CallPat`
+
+ cp_qvars = [a, r::a, s::a], cp_args = [@a (r,s)]
+
+Doing so isn't trivial, though.
+
+For now we content ourselves with a simpler plan: eliminate a call pattern
+if another pattern subsumes it; this is done by `subsumePats`.
+For example here are two patterns
+
+ cp_qvars = [a, r::a, s::a], cp_args = [@a (r,s)]
+ cp_qvars = [x::Int, y::Int], cp_args = [@Int (x,y)]
+
+The first can be instantiated to the second, /by instantiating types only/.
+This subsumption relationship is checked by `betterPat`. Note that if
+we have
+
+ cp_qvars = [a, r::a, s::a], cp_args = [@a (r,s)]
+ cp_qvars = [], cp_args = [@Bool (True,False)]
+
+the first does *not* subsume the second; the second is more specific.
+
+In our initial example with `f @Int` and `f @Bool` neither subsumes the other,
+so we will get two essentially-identical specialisations. Boo. We rely on our
+crude throttling mechanisms to stop this getting out of control -- with
+polymorphic recursion we can generate an infinite number of specialisations.
+Example is Data.Sequence.adjustTree, I think.
-}
diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs
index 2b32f8103f7846054238938ea32e325fc5a1ce11..65645923a1c2bc76f176bb497146404c117d6125 100644
--- a/compiler/GHC/Core/Rules.hs
+++ b/compiler/GHC/Core/Rules.hs
@@ -9,7 +9,7 @@
-- The 'CoreRule' datatype itself is declared elsewhere.
module GHC.Core.Rules (
-- ** Looking up rules
- lookupRule,
+ lookupRule, matchExprs,
-- ** RuleBase, RuleEnv
RuleBase, RuleEnv(..), mkRuleEnv, emptyRuleEnv,
@@ -720,15 +720,23 @@ matchN :: InScopeEnv
-- trailing ones, returning the result of applying the rule to a prefix
-- of the actual arguments.
-matchN (ISE in_scope id_unf) rule_name tmpl_vars tmpl_es target_es rhs
+matchN ise _rule_name tmpl_vars tmpl_es target_es rhs
+ = do { (bind_wrapper, matched_es) <- matchExprs ise tmpl_vars tmpl_es target_es
+ ; return (bind_wrapper $
+ mkLams tmpl_vars rhs `mkApps` matched_es) }
+
+matchExprs :: InScopeEnv -> [Var] -> [CoreExpr] -> [CoreExpr]
+ -> Maybe (BindWrapper, [CoreExpr]) -- 1-1 with the [Var]
+matchExprs (ISE in_scope id_unf) tmpl_vars tmpl_es target_es
= do { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es
; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst)
(mkEmptySubst in_scope) $
tmpl_vars `zip` tmpl_vars1
- bind_wrapper = rs_binds rule_subst
+
+ ; let bind_wrapper = rs_binds rule_subst
-- Floated bindings; see Note [Matching lets]
- ; return (bind_wrapper $
- mkLams tmpl_vars rhs `mkApps` matched_es) }
+
+ ; return (bind_wrapper, matched_es) }
where
(init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars
-- See Note [Cloning the template binders]
@@ -739,7 +747,7 @@ matchN (ISE in_scope id_unf) rule_name tmpl_vars tmpl_es target_es rhs
, rv_unf = id_unf }
lookup_tmpl :: RuleSubst -> Subst -> (InVar,OutVar) -> (Subst, CoreExpr)
- -- Need to return a RuleSubst solely for the benefit of mk_fake_ty
+ -- Need to return a RuleSubst solely for the benefit of fake_ty
lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst })
tcv_subst (tmpl_var, tmpl_var1)
| isId tmpl_var1
@@ -768,7 +776,6 @@ matchN (ISE in_scope id_unf) rule_name tmpl_vars tmpl_es target_es rhs
unbound tmpl_var
= pprPanic "Template variable unbound in rewrite rule" $
vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var)
- , text "Rule" <+> pprRuleName rule_name
, text "Rule bndrs:" <+> ppr tmpl_vars
, text "LHS args:" <+> ppr tmpl_es
, text "Actual args:" <+> ppr target_es ]
diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs
index 23c643b142a72fc5501d290334c6388661bc0a61..757a025db591afa2b339ae142e7e8f7d4d721812 100644
--- a/compiler/GHC/Core/Subst.hs
+++ b/compiler/GHC/Core/Subst.hs
@@ -19,7 +19,7 @@ module GHC.Core.Subst (
substTickish, substDVarSet, substIdInfo,
-- ** Operations on substitutions
- emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, isEmptySubst,
+ emptySubst, mkEmptySubst, mkTCvSubst, mkOpenSubst, isEmptySubst,
extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList,
extendIdSubstWithClone,
extendSubst, extendSubstList, extendSubstWithVar,
diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs
index 35ac0e0ee2747ed2ba2f46ca5b1990eb4d2a564c..28748c7c3dafc3761502fbfa7a1018c16f614fe4 100644
--- a/compiler/GHC/Core/TyCo/Subst.hs
+++ b/compiler/GHC/Core/TyCo/Subst.hs
@@ -14,7 +14,7 @@ module GHC.Core.TyCo.Subst
Subst(..), TvSubstEnv, CvSubstEnv, IdSubstEnv,
emptyIdSubstEnv, emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubst,
emptySubst, mkEmptySubst, isEmptyTCvSubst, isEmptySubst,
- mkSubst, mkTvSubst, mkCvSubst, mkIdSubst,
+ mkTCvSubst, mkTvSubst, mkCvSubst, mkIdSubst,
getTvSubstEnv, getIdSubstEnv,
getCvSubstEnv, getSubstInScope, setInScope, getSubstRangeTyCoFVs,
isInScope, elemSubst, notElemSubst, zapSubst,
@@ -271,8 +271,8 @@ isEmptyTCvSubst :: Subst -> Bool
isEmptyTCvSubst (Subst _ _ tv_env cv_env)
= isEmptyVarEnv tv_env && isEmptyVarEnv cv_env
-mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst
-mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs
+mkTCvSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> Subst
+mkTCvSubst in_scope tvs cvs = Subst in_scope emptyIdSubstEnv tvs cvs
mkIdSubst :: InScopeSet -> IdSubstEnv -> Subst
mkIdSubst in_scope ids = Subst in_scope ids emptyTvSubstEnv emptyCvSubstEnv
diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index 64af65205f6a449281d61b0fb40a4cde4b68acd3..b0febe808aa82a98a89a0b1e3b3f3fc50cbfab65 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -198,7 +198,7 @@ module GHC.Core.Type (
-- ** Manipulating type substitutions
emptyTvSubstEnv, emptySubst, mkEmptySubst,
- mkSubst, zipTvSubst, mkTvSubstPrs,
+ mkTCvSubst, zipTvSubst, mkTvSubstPrs,
zipTCvSubst,
notElemSubst,
getTvSubstEnv,
diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs
index 44485b4038c6a572c9208613e0c9bd8bf84529f0..8dcbc09953be5e9db751e8c8e4697e3b52ff3bb9 100644
--- a/compiler/GHC/Core/Unify.hs
+++ b/compiler/GHC/Core/Unify.hs
@@ -1481,7 +1481,7 @@ getSubst :: UMEnv -> UM Subst
getSubst env = do { tv_env <- getTvSubstEnv
; cv_env <- getCvSubstEnv
; let in_scope = rnInScopeSet (um_rn_env env)
- ; return (mkSubst in_scope tv_env cv_env emptyIdSubstEnv) }
+ ; return (mkTCvSubst in_scope tv_env cv_env) }
extendTvEnv :: TyVar -> Type -> UM ()
extendTvEnv tv ty = UM $ \state ->
diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs
index a55f1506480b0cf107396563c6a23e9a5e23a148..bcefd9d6d576462edfceb4081b0b51a9e49ebfb2 100644
--- a/compiler/GHC/Tc/Utils/TcType.hs
+++ b/compiler/GHC/Tc/Utils/TcType.hs
@@ -166,7 +166,7 @@ module GHC.Tc.Utils.TcType (
extendSubstInScopeList, extendSubstInScopeSet, extendTvSubstAndInScope,
Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr,
Type.extendTvSubst,
- isInScope, mkSubst, mkTvSubst, zipTyEnv, zipCoEnv,
+ isInScope, mkTCvSubst, mkTvSubst, zipTyEnv, zipCoEnv,
Type.substTy, substTys, substScaledTys, substTyWith, substTyWithCoVars,
substTyAddInScope,
substTyUnchecked, substTysUnchecked, substScaledTyUnchecked,
diff --git a/testsuite/tests/simplCore/should_compile/T24229a.hs b/testsuite/tests/simplCore/should_compile/T24229a.hs
new file mode 100644
index 0000000000000000000000000000000000000000..98f82b6ef161beebe79acca6c505e946f3907515
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T24229a.hs
@@ -0,0 +1,14 @@
+module T24229a where
+
+newtype N a = MkN a
+
+foo :: Int -> N (a,a) -> Maybe (a,a)
+foo 0 (MkN p) = Just p
+foo n (MkN (x,y)) = foo (n-1) (MkN (y,x))
+
+-- We should generate ONE specialisation for $wfoo,
+-- and it should fire TWICE, regardless of the order
+-- of the following two definitions.
+
+wombat1 = foo 20 (MkN ("yes", "no"))
+wombat2 xs ys = foo 3 (MkN (xs, ys))
diff --git a/testsuite/tests/simplCore/should_compile/T24229a.stderr b/testsuite/tests/simplCore/should_compile/T24229a.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..2328ccd920a7cf2f0dc1712ea36cf1996a10bf4d
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T24229a.stderr
@@ -0,0 +1,38 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core = {terms: 79, types: 106, coercions: 8, joins: 0/0}
+
+Rec {
+foo_$s$wfoo
+ = \ @a sc sc1 sc2 ->
+ case sc2 of ds {
+ __DEFAULT -> foo_$s$wfoo sc1 sc (-# ds 1#);
+ 0# -> (# (sc, sc1) #)
+ }
+end Rec }
+
+foo
+ = \ @a ds ds1 ->
+ case ds of { I# ww ->
+ case ww of ds2 {
+ __DEFAULT -> case ds1 `cast` <Co:4> :: ... of { (x, y) -> case foo_$s$wfoo y x (-# ds2 1#) of { (# ww1 #) -> Just ww1 } };
+ 0# -> Just (ds1 `cast` <Co:4> :: ...)
+ }
+ }
+
+wombat7 = "yes"#
+
+wombat6 = unpackCString# wombat7
+
+wombat5 = "no"#
+
+wombat4 = unpackCString# wombat5
+
+wombat1 = case foo_$s$wfoo wombat6 wombat4 20# of { (# ww #) -> Just ww }
+
+wombat8 = I# 3#
+
+wombat2 = \ @a xs ys -> case foo_$s$wfoo xs ys 3# of { (# ww #) -> Just ww }
+
+
+
diff --git a/testsuite/tests/simplCore/should_compile/T24229b.hs b/testsuite/tests/simplCore/should_compile/T24229b.hs
new file mode 100644
index 0000000000000000000000000000000000000000..df77d1839d8516069ca99cae9e5653cdb8b48e41
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T24229b.hs
@@ -0,0 +1,13 @@
+module T24229b where
+
+newtype N a = MkN a
+
+foo :: Int -> N (a,a) -> Maybe (a,a)
+foo 0 (MkN p) = Just p
+foo n (MkN (x,y)) = foo (n-1) (MkN (y,x))
+
+-- We should generate ONE specialisation for $wfoo,
+-- and it should fire TWICE, regardless of the order
+-- of the following two definitions.
+
+wombat2 xs ys = foo 3 (MkN (xs, ys))
diff --git a/testsuite/tests/simplCore/should_compile/T24229b.stderr b/testsuite/tests/simplCore/should_compile/T24229b.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..46b1c3280b4f25ae8e7c54bed0b1ef3bfed88745
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T24229b.stderr
@@ -0,0 +1,28 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core = {terms: 60, types: 83, coercions: 8, joins: 0/0}
+
+Rec {
+foo_$s$wfoo
+ = \ @a sc sc1 sc2 ->
+ case sc2 of ds {
+ __DEFAULT -> foo_$s$wfoo sc1 sc (-# ds 1#);
+ 0# -> (# (sc, sc1) #)
+ }
+end Rec }
+
+foo
+ = \ @a ds ds1 ->
+ case ds of { I# ww ->
+ case ww of ds2 {
+ __DEFAULT -> case ds1 `cast` <Co:4> :: ... of { (x, y) -> case foo_$s$wfoo y x (-# ds2 1#) of { (# ww1 #) -> Just ww1 } };
+ 0# -> Just (ds1 `cast` <Co:4> :: ...)
+ }
+ }
+
+wombat1 = I# 3#
+
+wombat2 = \ @a xs ys -> case foo_$s$wfoo xs ys 3# of { (# ww #) -> Just ww }
+
+
+