summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorÖmer Sinan Ağacan <omeragacan@gmail.com>2018-10-10 10:07:05 +0300
committerÖmer Sinan Ağacan <omeragacan@gmail.com>2018-10-10 10:07:21 +0300
commitac977688523e5d77eb6f041f043552410b0c21da (patch)
treed77cb46adac639d002489f7c2432852a9a506a22
parentd728c3c578cc9e9205def2c1e96934487b364b7b (diff)
downloadhaskell-ac977688523e5d77eb6f041f043552410b0c21da.tar.gz
Fix dataToTag# argument evaluation
See #15696 for more details. We now always enter dataToTag# argument (done in generated Cmm, in StgCmmExpr). Any high-level optimisations on dataToTag# applications are done by the simplifier. Looking at tag bits (instead of reading the info table) for small types is left to another diff. Incorrect test T14626 is removed. We no longer do this optimisation (see comment:44, comment:45, comment:60). Comments and notes about special cases around dataToTag# are removed. We no longer have any special cases around it in Core. Other changes related to evaluating primops (seq# and dataToTag#) will be pursued in follow-up diffs. Test Plan: Validates with three regression tests Reviewers: simonpj, simonmar, hvr, bgamari, dfeuer Reviewed By: simonmar Subscribers: rwbarton, carter GHC Trac Issues: #15696 Differential Revision: https://phabricator.haskell.org/D5201
-rw-r--r--compiler/codeGen/StgCmmExpr.hs12
-rw-r--r--compiler/codeGen/StgCmmPrim.hs6
-rw-r--r--compiler/coreSyn/CorePrep.hs71
-rw-r--r--compiler/coreSyn/CoreUtils.hs17
-rw-r--r--compiler/prelude/PrelRules.hs13
-rw-r--r--compiler/prelude/PrimOp.hs1
-rw-r--r--compiler/prelude/primops.txt.pp44
-rw-r--r--libraries/base/GHC/Base.hs11
-rw-r--r--testsuite/tests/codeGen/should_compile/Makefile3
-rw-r--r--testsuite/tests/codeGen/should_compile/T14626.hs15
-rw-r--r--testsuite/tests/codeGen/should_compile/all.T3
-rw-r--r--testsuite/tests/codeGen/should_run/T15696_1.hs26
-rw-r--r--testsuite/tests/codeGen/should_run/T15696_1.stdout1
-rw-r--r--testsuite/tests/codeGen/should_run/T15696_2.hs17
-rw-r--r--testsuite/tests/codeGen/should_run/T15696_2.stdout2
-rw-r--r--testsuite/tests/codeGen/should_run/T15696_3.hs9
-rw-r--r--testsuite/tests/codeGen/should_run/T15696_3.stdout1
-rw-r--r--testsuite/tests/codeGen/should_run/all.T10
18 files changed, 102 insertions, 160 deletions
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 22fcfaf412..1af8fb3376 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -65,6 +65,16 @@ cgExpr (StgApp fun args) = cgIdApp fun args
cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =
cgIdApp a []
+-- dataToTag# :: a -> Int#
+-- See Note [dataToTag#] in primops.txt.pp
+cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do
+ dflags <- getDynFlags
+ emitComment (mkFastString "dataToTag#")
+ tmp <- newTemp (bWord dflags)
+ _ <- withSequel (AssignTo [tmp] False) (cgIdApp a [])
+ -- TODO: For small types look at the tag bits instead of reading info table
+ emitReturn [getConstrTag dflags (cmmUntag dflags (CmmReg (CmmLocal tmp)))]
+
cgExpr (StgOpApp op args ty) = cgOpApp op args ty
cgExpr (StgConApp con args _)= cgConApp con args
cgExpr (StgTick t e) = cgTick t >> cgExpr e
@@ -550,6 +560,8 @@ isSimpleScrut _ _ = return False
isSimpleOp :: StgOp -> [StgArg] -> FCode Bool
-- True iff the op cannot block or allocate
isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe)
+-- dataToTag# evalautes its argument, see Note [dataToTag#] in primops.txt.pp
+isSimpleOp (StgPrimOp DataToTagOp) _ = return False
isSimpleOp (StgPrimOp op) stg_args = do
arg_exprs <- getNonVoidArgAmodes stg_args
dflags <- getDynFlags
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index f5437c0c3b..c90264f14f 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -37,7 +37,6 @@ import BlockId
import MkGraph
import StgSyn
import Cmm
-import CmmInfo
import Type ( Type, tyConAppTyCon )
import TyCon
import CLabel
@@ -363,11 +362,6 @@ emitPrimOp _ [res] AddrToAnyOp [arg]
emitPrimOp _ [res] AnyToAddrOp [arg]
= emitAssign (CmmLocal res) arg
--- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
--- Note: argument may be tagged!
-emitPrimOp dflags [res] DataToTagOp [arg]
- = emitAssign (CmmLocal res) (getConstrTag dflags (cmmUntag dflags arg))
-
{- Freezing arrays-of-ptrs requires changing an info table, for the
benefit of the generational collector. It needs to scavenge mutable
objects, even if they are in old space. When they become immutable,
diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index 26706b1cdd..19b6364e1e 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -43,7 +43,6 @@ import Id
import IdInfo
import TysWiredIn
import DataCon
-import PrimOp
import BasicTypes
import Module
import UniqSupply
@@ -1071,10 +1070,6 @@ The type is the type of the entire application
maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
maybeSaturate fn expr n_args
- | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg
- -- A gruesome special case
- = saturateDataToTag sat_expr
-
| hasNoBinding fn -- There's no binding
= return sat_expr
@@ -1085,52 +1080,7 @@ maybeSaturate fn expr n_args
excess_arity = fn_arity - n_args
sat_expr = cpeEtaExpand excess_arity expr
--------------
-saturateDataToTag :: CpeApp -> UniqSM CpeApp
--- See Note [dataToTag magic]
-saturateDataToTag sat_expr
- = do { let (eta_bndrs, eta_body) = collectBinders sat_expr
- ; eta_body' <- eval_data2tag_arg eta_body
- ; return (mkLams eta_bndrs eta_body') }
- where
- eval_data2tag_arg :: CpeApp -> UniqSM CpeBody
- eval_data2tag_arg app@(fun `App` arg)
- | exprIsHNF arg -- Includes nullary constructors
- = return app -- The arg is evaluated
- | otherwise -- Arg not evaluated, so evaluate it
- = do { arg_id <- newVar (exprType arg)
- ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding
- ; return (Case arg arg_id1 (exprType app)
- [(DEFAULT, [], fun `App` Var arg_id1)]) }
-
- eval_data2tag_arg (Tick t app) -- Scc notes can appear
- = do { app' <- eval_data2tag_arg app
- ; return (Tick t app') }
-
- eval_data2tag_arg other -- Should not happen
- = pprPanic "eval_data2tag" (ppr other)
-
-{- Note [dataToTag magic]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-We must ensure that the arg of data2TagOp is evaluated. So
-in general CorePrep does this transformation:
- data2tag e --> case e of y -> data2tag y
-(yuk yuk) take into account the lambdas we've now introduced
-
-How might it not be evaluated? Well, we might have floated it out
-of the scope of a `seq`, or dropped the `seq` altogether.
-
-We only do this if 'e' is not a WHNF. But if it's a simple
-variable (common case) we need to know its evaluated-ness flag.
-Example:
- data T = MkT !Bool
- f v = case v of
- MkT y -> dataToTag# y
-Here we don't want to generate an extra case on 'y', because it's
-already evaluated. So we want to keep the evaluated-ness flag
-on y. See Note [Preserve evaluated-ness in CorePrep].
-
-
+{-
************************************************************************
* *
Simple CoreSyn operations
@@ -1630,7 +1580,7 @@ cpCloneBndr env bndr
-- Drop (now-useless) rules/unfoldings
-- See Note [Drop unfoldings and rules]
- -- and Note [Preserve evaluated-ness in CorePrep]
+ -- and Note [Preserve evaluatedness] in CoreTidy
; let unfolding' = zapUnfolding (realIdUnfolding bndr)
-- Simplifier will set the Id's unfolding
@@ -1662,21 +1612,8 @@ We want to drop the unfolding/rules on every Id:
- We are changing uniques, so if we didn't discard unfoldings/rules
we'd have to substitute in them
-HOWEVER, we want to preserve evaluated-ness; see
-Note [Preserve evaluated-ness in CorePrep]
-
-Note [Preserve evaluated-ness in CorePrep]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We want to preserve the evaluated-ness of each binder (via
-evaldUnfolding) for two reasons
-
-* In the code generator if we have
- case x of y { Red -> e1; DEFAULT -> y }
- we can return 'y' rather than entering it, if we know
- it is evaluated (Trac #14626)
-
-* In the DataToTag magic (in CorePrep itself) we rely on
- evaluated-ness. See Note Note [dataToTag magic].
+HOWEVER, we want to preserve evaluated-ness;
+see Note [Preserve evaluatedness] in CoreTidy.
-}
------------------------------------------------------------------------------
diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index 453d984ec4..6dfb1df462 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -1696,23 +1696,6 @@ Well, yes. The primop accepts lifted arguments and does not
evaluate them. Indeed, in general primops are, well, primitive
and do not perform evaluation.
-There is one primop, dataToTag#, which does /require/ a lifted
-argument to be evaluated. To ensure this, CorePrep adds an
-eval if it can't see the argument is definitely evaluated
-(see [dataToTag magic] in CorePrep).
-
-We make no attempt to guarantee that dataToTag#'s argument is
-evaluated here. Main reason: it's very fragile to test for the
-evaluatedness of a lifted argument. Consider
- case x of y -> let v = dataToTag# y in ...
-
-where x/y have type Int, say. 'y' looks evaluated (by the enclosing
-case) so all is well. Now the FloatOut pass does a binder-swap (for
-very good reasons), changing to
- case x of y -> let v = dataToTag# x in ...
-
-See also Note [dataToTag#] in primops.txt.pp.
-
Bottom line:
* in exprOkForSpeculation we simply ignore all lifted arguments.
* except see Note [seq# and expr_ok] for an exception
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index e94490007f..28c0628f16 100644
--- a/compiler/prelude/PrelRules.hs
+++ b/compiler/prelude/PrelRules.hs
@@ -1030,19 +1030,6 @@ dataToTagRule = a `mplus` b
guard $ ty1 `eqType` ty2
return tag
- -- Why don't we simplify tagToEnum# (dataToTag# x) to x? We would
- -- like to, but it seems tricky. See #14282. The trouble is that
- -- we never actually see tagToEnum# (dataToTag# x). Because dataToTag#
- -- is can_fail, this expression is immediately transformed into
- --
- -- case dataToTag# @T x of wild
- -- { __DEFAULT -> tagToEnum# @T wild }
- --
- -- and wild has no unfolding. Simon Peyton Jones speculates one way around
- -- might be to arrange to give unfoldings to case binders of CONLIKE
- -- applications and mark dataToTag# CONLIKE, but he doubts it's really
- -- worth the trouble.
-
-- dataToTag (K e1 e2) ==> tag-of K
-- This also works (via exprIsConApp_maybe) for
-- dataToTag x
diff --git a/compiler/prelude/PrimOp.hs b/compiler/prelude/PrimOp.hs
index 4eb94e9fdb..369f17f7f5 100644
--- a/compiler/prelude/PrimOp.hs
+++ b/compiler/prelude/PrimOp.hs
@@ -279,7 +279,6 @@ Invariants:
These primops are pretty weird.
- dataToTag# :: a -> Int (arg must be an evaluated data type)
tagToEnum# :: Int -> a (result type must be an enumerated type)
The constraints aren't currently checked by the front end, but the
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 7360ccb758..303c902c83 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -1070,7 +1070,7 @@ primop CopySmallMutableArrayOp "copySmallMutableArray#" GenPrimOp
to the destination array. The source and destination arrays can
refer to the same array. Both arrays must fully contain the
specified ranges, but this is not checked.
- The regions are allowed to overlap, although this is only possible when the same
+ The regions are allowed to overlap, although this is only possible when the same
array is provided as both the source and the destination. }
with
out_of_line = True
@@ -1940,7 +1940,7 @@ primop CopyMutableArrayArrayOp "copyMutableArrayArray#" GenPrimOp
{Copy a range of the first MutableArrayArray# to the specified region in the second
MutableArrayArray#.
Both arrays must fully contain the specified ranges, but this is not checked.
- The regions are allowed to overlap, although this is only possible when the same
+ The regions are allowed to overlap, although this is only possible when the same
array is provided as both the source and the destination.
}
with
@@ -2915,7 +2915,7 @@ primop ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp
-- Note [reallyUnsafePtrEquality#]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
+--
-- reallyUnsafePtrEquality# can't actually fail, per se, but we mark it can_fail
-- anyway. Until 5a9a1738023a, GHC considered primops okay for speculation only
-- when their arguments were known to be forced. This was unnecessarily
@@ -2924,22 +2924,20 @@ primop ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp
-- sometimes lose track of whether those arguments were forced, leading to let/app
-- invariant failures (see Trac 13027 and the discussion in Trac 11444). Now that
-- ok_for_speculation skips over lifted arguments, we need to explicitly prevent
--- reallyUnsafePtrEquality# from floating out. The reasons are closely related
--- to those described in Note [dataToTag#], although the consequences are less
--- severe. Imagine if we had
---
+-- reallyUnsafePtrEquality# from floating out. Imagine if we had
+--
-- \x y . case x of x'
-- DEFAULT ->
-- case y of y'
-- DEFAULT ->
-- let eq = reallyUnsafePtrEquality# x' y'
-- in ...
---
+--
-- If the let floats out, we'll get
---
+--
-- \x y . let eq = reallyUnsafePtrEquality# x y
-- in case x of ...
---
+--
-- The trouble is that pointer equality between thunks is very different
-- from pointer equality between the values those thunks reduce to, and the latter
-- is typically much more precise.
@@ -2990,31 +2988,29 @@ primop DataToTagOp "dataToTag#" GenPrimOp
with
can_fail = True -- See Note [dataToTag#]
strictness = { \ _arity -> mkClosedStrictSig [evalDmd] topRes }
- -- dataToTag# must have an evaluated argument
primop TagToEnumOp "tagToEnum#" GenPrimOp
Int# -> a
-- Note [dataToTag#]
--- ~~~~~~~~~~~~~~~~~~~~
--- The dataToTag# primop should always be applied to an evaluated argument.
--- The way to ensure this is to invoke it via the 'getTag' wrapper in GHC.Base:
--- getTag :: a -> Int#
--- getTag !x = dataToTag# x
+-- ~~~~~~~~~~~~~~~~~
+-- dataToTag# evaluates its argument, so we don't want to float it out.
+-- Consider:
--
--- But now consider
-- \z. case x of y -> let v = dataToTag# y in ...
--
-- To improve floating, the FloatOut pass (deliberately) does a
-- binder-swap on the case, to give
+--
-- \z. case x of y -> let v = dataToTag# x in ...
--
--- Now FloatOut might float that v-binding outside the \z. But that is
--- bad because that might mean x gets evaluated much too early! (CorePrep
--- adds an eval to a dataToTag# call, to ensure that the argument really is
--- evaluated; see CorePrep Note [dataToTag magic].)
+-- Now FloatOut might float that v-binding outside the \z
+--
+-- let v = dataToTag# x in \z. case x of y -> ...
+--
+-- But that is bad because that might mean x gets evaluated much too early!
--
--- Solution: make DataToTag into a can_fail primop. That will stop it floating
+-- Solution: make dataToTag# into a can_fail primop. That will stop it floating
-- (see Note [PrimOp can_fail and has_side_effects] in PrimOp). It's a bit of
-- a hack but never mind.
@@ -3126,8 +3122,8 @@ pseudoop "proxy#"
pseudoop "seq"
a -> b -> b
{ The value of {\tt seq a b} is bottom if {\tt a} is bottom, and
- otherwise equal to {\tt b}. In other words, it evaluates the first
- argument {\tt a} to weak head normal form (WHNF). {\tt seq} is usually
+ otherwise equal to {\tt b}. In other words, it evaluates the first
+ argument {\tt a} to weak head normal form (WHNF). {\tt seq} is usually
introduced to improve performance by avoiding unneeded laziness.
A note on evaluation order: the expression {\tt seq a b} does
diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs
index 1c927405ce..d1f87e1d62 100644
--- a/libraries/base/GHC/Base.hs
+++ b/libraries/base/GHC/Base.hs
@@ -1388,19 +1388,10 @@ unIO (IO a) = a
{- |
Returns the tag of a constructor application; this function is used
by the deriving code for Eq, Ord and Enum.
-
-The primitive dataToTag# requires an evaluated constructor application
-as its argument, so we provide getTag as a wrapper that performs the
-evaluation before calling dataToTag#. We could have dataToTag#
-evaluate its argument, but we prefer to do it this way because (a)
-dataToTag# can be an inline primop if it doesn't need to do any
-evaluation, and (b) we want to expose the evaluation to the
-simplifier, because it might be possible to eliminate the evaluation
-in the case when the argument is already known to be evaluated.
-}
{-# INLINE getTag #-}
getTag :: a -> Int#
-getTag !x = dataToTag# x
+getTag x = dataToTag# x
----------------------------------------------
-- Numeric primops
diff --git a/testsuite/tests/codeGen/should_compile/Makefile b/testsuite/tests/codeGen/should_compile/Makefile
index c94c8b6f92..a1fc58f89b 100644
--- a/testsuite/tests/codeGen/should_compile/Makefile
+++ b/testsuite/tests/codeGen/should_compile/Makefile
@@ -5,9 +5,6 @@ include $(TOP)/mk/test.mk
T2578:
'$(TEST_HC)' $(TEST_HC_OPTS) --make T2578 -fforce-recomp -v0
-T14626:
- '$(TEST_HC)' $(TEST_HC_OPTS) -c -O -ddump-prep -dsuppress-uniques T14626.hs | grep case
-
debug:
# Without optimisations, we should get annotations for basically
# all expressions in the example program.
diff --git a/testsuite/tests/codeGen/should_compile/T14626.hs b/testsuite/tests/codeGen/should_compile/T14626.hs
deleted file mode 100644
index a665694bfc..0000000000
--- a/testsuite/tests/codeGen/should_compile/T14626.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-{-# LANGUAGE MagicHash #-}
-
-module T14626 where
-
-import GHC.Prim
-
-data T = MkT !Bool
-
-f v = case v of
- MkT y -> dataToTag# y
-
--- This should /not/ produce an inner case on the y, thus:
--- f v = case v of
--- MkT y -> case y of z -> dataToTag# z
--- But it was! See Trac #14626 comment:4
diff --git a/testsuite/tests/codeGen/should_compile/all.T b/testsuite/tests/codeGen/should_compile/all.T
index dd6931f235..a5d5a47034 100644
--- a/testsuite/tests/codeGen/should_compile/all.T
+++ b/testsuite/tests/codeGen/should_compile/all.T
@@ -35,9 +35,6 @@ test('T10667', [ when((arch('powerpc64') or arch('powerpc64le')),
compile, ['-g'])
test('T12115', normal, compile, [''])
test('T12355', normal, compile, [''])
-test('T14626',
- normal,
- run_command, ['$MAKE -s --no-print-directory T14626'])
test('T14999',
[when((arch('powerpc64') or arch('powerpc64le')), expect_broken(11261)),
unless(opsys('linux') and arch('x86_64') and have_gdb() and
diff --git a/testsuite/tests/codeGen/should_run/T15696_1.hs b/testsuite/tests/codeGen/should_run/T15696_1.hs
new file mode 100644
index 0000000000..e747c0ad16
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T15696_1.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE MagicHash #-}
+
+import GHC.Exts
+import GHC.Prim
+
+main :: IO ()
+main = print (cmpT a T2)
+ where
+ {-# NOINLINE f #-}
+ f = T2
+ {-# NOINLINE a #-}
+ a = f
+
+data T = T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9
+
+cmpT a b
+ = case dataToTag# a of
+ a' -> case dataToTag# b of
+ b' ->
+ if tagToEnum# (a' <# b') :: Bool then
+ LT -- used to return this
+ else
+ if tagToEnum# (a' ==# b') :: Bool then
+ EQ -- should return this
+ else
+ GT
diff --git a/testsuite/tests/codeGen/should_run/T15696_1.stdout b/testsuite/tests/codeGen/should_run/T15696_1.stdout
new file mode 100644
index 0000000000..03426a729d
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T15696_1.stdout
@@ -0,0 +1 @@
+EQ
diff --git a/testsuite/tests/codeGen/should_run/T15696_2.hs b/testsuite/tests/codeGen/should_run/T15696_2.hs
new file mode 100644
index 0000000000..1a404bee92
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T15696_2.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE MagicHash #-}
+
+import GHC.Exts
+import GHC.Prim
+
+main :: IO ()
+main = do
+ print (I# (dataToTag# a)) -- used to print 0, should print 1
+ print (I# (dataToTag# f)) -- used to print 1 correctly
+
+ where
+ {-# NOINLINE f #-}
+ f = T2
+ {-# NOINLINE a #-}
+ a = f
+
+data T = T1 | T2
diff --git a/testsuite/tests/codeGen/should_run/T15696_2.stdout b/testsuite/tests/codeGen/should_run/T15696_2.stdout
new file mode 100644
index 0000000000..6ed281c757
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T15696_2.stdout
@@ -0,0 +1,2 @@
+1
+1
diff --git a/testsuite/tests/codeGen/should_run/T15696_3.hs b/testsuite/tests/codeGen/should_run/T15696_3.hs
new file mode 100644
index 0000000000..73b7f3cde6
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T15696_3.hs
@@ -0,0 +1,9 @@
+import qualified Data.Set as S
+
+main = print $
+ let {-# noinline f #-}
+ f () = T2
+ in S.fromList [f (), f ()]
+
+data T = T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9
+ deriving (Show, Read, Eq, Ord, Bounded, Enum)
diff --git a/testsuite/tests/codeGen/should_run/T15696_3.stdout b/testsuite/tests/codeGen/should_run/T15696_3.stdout
new file mode 100644
index 0000000000..307f49a11a
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T15696_3.stdout
@@ -0,0 +1 @@
+fromList [T2]
diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T
index bd1521d6d8..eaf0e77b97 100644
--- a/testsuite/tests/codeGen/should_run/all.T
+++ b/testsuite/tests/codeGen/should_run/all.T
@@ -172,4 +172,12 @@ test('T13825-unit',
test('T14619', normal, compile_and_run, [''])
test('T14754', normal, compile_and_run, [''])
test('T14346', only_ways(['threaded1','threaded2']), compile_and_run, ['-O -threaded'])
-test('T14251', normal, compile_and_run, [''])
+test('T14251', [expect_broken_for(14251, [''])],
+ compile_and_run, [''])
+
+# These actually used to fail with all optimisation settings, but adding -O just
+# to make sure
+test('T15696_1', normal, compile_and_run, ['-O'])
+test('T15696_2', normal, compile_and_run, ['-O'])
+# This requires -O
+test('T15696_3', normal, compile_and_run, ['-O'])