diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs
index 9b24604404d1f583c99d272e456b9bddcaf49979..c5d286d9d96cd8d9b43fad9b84a91107fbfd5aca 100644
--- a/compiler/specialise/SpecConstr.hs
+++ b/compiler/specialise/SpecConstr.hs
@@ -1144,7 +1144,9 @@ scExpr' _ e@(Lit {}) = return (nullUsage, e)
scExpr' env (Tick t e) = do (usg, e') <- scExpr env e
return (usg, Tick t e')
scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
- return (usg, Cast e' (scSubstCo env co))
+ return (usg, mkCast e' (scSubstCo env co))
+ -- Important to use mkCast here
+ -- See Note [SpecConstr call patterns]
scExpr' env e@(App _ _) = scApp env (collectArgs e)
scExpr' env (Lam b e) = do let (env', b') = extendBndr env b
(usg, e') <- scExpr env' e
@@ -1727,9 +1729,27 @@ BUT phantom type synonyms can mess this reasoning up,
eg x::T b with type T b = Int
So we apply expandTypeSynonyms to the bound Ids.
See Trac # 5458. Yuk.
+
+Note [SpecConstr call patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A "call patterns" that we collect is going to become the LHS of a RULE.
+It's important that it doesn't have
+ e |> Refl
+or
+ e |> g1 |> g2
+because both of these will be optimised by Simplify.simplRule. In the
+former case such optimisation benign, because the rule will match more
+terms; but in the latter we may lose a binding of 'g1' or 'g2', and
+end up with a rule LHS that doesn't bind the template variables (Trac
+#10602).
+
+The simplifier eliminates such things, but SpecConstr itself constructs
+new terms by substituting. So the 'mkCast' in the Cast case of scExpr
+is very important!
-}
type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments
+ -- See Note [SpecConstr call patterns]
callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
-- Result has no duplicate patterns,
@@ -1849,9 +1869,6 @@ argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ
-}
argToPat env in_scope val_env (Cast arg co) arg_occ
- | isReflCo co -- Substitution in the SpecConstr itself
- -- can lead to identity coercions
- = argToPat env in_scope val_env arg arg_occ
| not (ignoreType env ty2)
= do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
; if not interesting then
diff --git a/testsuite/tests/simplCore/should_compile/T10602.hs b/testsuite/tests/simplCore/should_compile/T10602.hs
index fc2523d33e5954cca3796ed42ff598b2f837b4b4..c29d743fab99cee4e92fcc1c2ee5cf2444cf7b60 100644
--- a/testsuite/tests/simplCore/should_compile/T10602.hs
+++ b/testsuite/tests/simplCore/should_compile/T10602.hs
@@ -1,34 +1,26 @@
-import Control.Monad
-import Data.Binary
-import Data.List
+{-# OPTIONS_GHC -O2 #-}
+{-# OPTIONS_GHC -fno-warn-missing-methods #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- {-# OPTIONS_GHC -fno-spec-constr #-} -- Makes the problem go away.
+-- {-# OPTIONS_GHC -fspec-constr-count=1 #-} -- Makes the problem go away.
-newtype A a = A [a]
+module T10602 where
-instance Binary a => Binary (A a) where
- put (A xs) = case splitAt 254 xs of
- (_, []) -> mapM_ put xs
- (a, b) -> put (A b)
+-- Copy-pasting T10602b.hs into the current module makes the problem go away.
+import T10602b
- get = do xs <- replicateM 254 get
- A ys <- get
- return $ A $ xs ++ ys
+data PairS a = PairS a a
-main :: IO ()
-main = undefined
+-- Removing the '~' makes the problem go away.
+(PairS _ _) >> ~(PairS b g) = PairS b g
-{-
-This intermittently failed with although I was never able to reliably reproduce,
+class Binary t where
+ put :: t -> PairS ()
-$ ./inplace/bin/ghc-stage2 -O2 Test.hs -fforce-recomp
-[1 of 1] Compiling Main ( Test.hs, Test.o )
-ghc-stage2: panic! (the 'impossible' happened)
- (GHC version 7.10.1.20150708 for x86_64-unknown-linux):
- Template variable unbound in rewrite rule
- sg_s5zh
- [sc_s5zf, sc_s5zg, sg_s5zh, sg_s5zi]
- [sc_s5zf, sc_s5zg, sg_s5zh, sg_s5zi]
- [: @ a_a3fv sc_s5zf sc_s5zg]
- [: @ a_a3fv sc_s5zb sc_s5zc]
+-- Not using a newtype makes the problem go away.
+newtype A a = A [a]
-Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug
--}
+instance Binary a => Binary (A a) where
+ put (A xs) = case splitAt 254 xs of
+ (_, []) -> foldr (>>) (PairS () ()) (map put xs)
+ (_, b) -> put (A b)
diff --git a/testsuite/tests/simplCore/should_compile/T10602b.hs b/testsuite/tests/simplCore/should_compile/T10602b.hs
new file mode 100644
index 0000000000000000000000000000000000000000..f90ad0a783194df0e0b7fa825c146271502c357d
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T10602b.hs
@@ -0,0 +1,20 @@
+{-# OPTIONS_GHC -O2 #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module T10602b (splitAt, map, foldr) where
+
+import GHC.Classes
+import GHC.Types
+import GHC.Num
+import GHC.Base
+
+splitAt :: Int -> [a] -> ([a],[a])
+splitAt n ls
+ | n <= 0 = ([], ls)
+ | otherwise = splitAt' n ls
+ where
+ splitAt' :: Int -> [a] -> ([a], [a])
+ splitAt' _ [] = ([], [])
+ splitAt' 1 (x:xs) = ([x], xs)
+ splitAt' m (x:xs) = (x:xs', xs'')
+ where
+ (xs', xs'') = splitAt' (m - 1) xs
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 6a211fbbb51217181de73aed1b24bc89cde83b3d..d2be73eb8fff37c0e04b8484235f8266f32d6ac5 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -210,5 +210,5 @@ test('T9400', only_ways(['optasm']), compile, ['-O0 -ddump-simpl -dsuppress-uniq
test('T9583', only_ways(['optasm']), compile, [''])
test('T9565', only_ways(['optasm']), compile, [''])
test('T10176', only_ways(['optasm']), compile, [''])
-test('T10602', only_ways(['optasm']), compile, ['-O2'])
+test('T10602', only_ways(['optasm']), multimod_compile, ['T10602','-v0'])
test('T10627', only_ways(['optasm']), compile, [''])