Commit 3cadf440 authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Ben Gamari
Browse files

Make sure rule LHSs are simplified

SpecConstr was generating a rule LHS with nested casts,
which the simplifier then optimised away.  Result: unbound
template variables.

Easily fixed.  See Note [SpecConstr call patterns]
parent 3794b597
......@@ -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
......
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)
{-# 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
......@@ -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, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment