Weaken wrinkle 1 of Note [Scrutinee Constant Folding]

Fixes #22375.

Co-authored-by:  Simon Peyton Jones <simon.peytonjones@gmail.com>

3 files changed, 83 insertions, 0 deletions

diff --git a/testsuite/tests/simplCore/should_compile/T22375.hs b/testsuite/tests/simplCore/should_compile/T22375.hs
new file mode 100644
index 0000000000..f2f9fb3d28
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T22375.hs
@@ -0,0 +1,12 @@
+module T22375 where
+
+data X = A | B | C | D | E
+  deriving Eq
+
+f :: X -> Int -> Int
+f x v
+  | x == A = 1 + v
+  | x == B = 2 + v
+  | x == C = 3 + v
+  | x == D = 4 + v
+  | otherwise = 5 + v
diff --git a/testsuite/tests/simplCore/should_compile/T22375.stderr b/testsuite/tests/simplCore/should_compile/T22375.stderr
new file mode 100644
index 0000000000..826d3bc8eb
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T22375.stderr
@@ -0,0 +1,70 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 71, types: 31, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 14, types: 7, coercions: 0, joins: 0/0}
+T22375.$fEqX_$c== :: X -> X -> Bool
+[GblId,
+ Arity=2,
+ Str=<SL><SL>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=True)}]
+T22375.$fEqX_$c==
+  = \ (a :: X) (b :: X) ->
+      case GHC.Prim.dataToTag# @X a of a# { __DEFAULT ->
+      case GHC.Prim.dataToTag# @X b of b# { __DEFAULT ->
+      GHC.Prim.tagToEnum# @Bool (GHC.Prim.==# a# b#)
+      }
+      }
+
+-- RHS size: {terms: 18, types: 7, coercions: 0, joins: 0/0}
+T22375.$fEqX_$c/= [InlPrag=INLINE (sat-args=2)] :: X -> X -> Bool
+[GblId,
+ Arity=2,
+ Str=<SL><SL>,
+ Unf=Unf{Src=StableUser, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=2,unsat_ok=False,boring_ok=False)}]
+T22375.$fEqX_$c/=
+  = \ (eta :: X) (eta1 :: X) ->
+      case GHC.Prim.dataToTag# @X eta of a# { __DEFAULT ->
+      case GHC.Prim.dataToTag# @X eta1 of b# { __DEFAULT ->
+      case GHC.Prim.==# a# b# of {
+        __DEFAULT -> GHC.Types.True;
+        1# -> GHC.Types.False
+      }
+      }
+      }
+
+-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
+T22375.$fEqX [InlPrag=CONLIKE] :: Eq X
+[GblId[DFunId],
+ Unf=DFun: \ ->
+       GHC.Classes.C:Eq TYPE: X T22375.$fEqX_$c== T22375.$fEqX_$c/=]
+T22375.$fEqX
+  = GHC.Classes.C:Eq @X T22375.$fEqX_$c== T22375.$fEqX_$c/=
+
+-- RHS size: {terms: 32, types: 5, coercions: 0, joins: 0/0}
+f [InlPrag=[2]] :: X -> Int -> Int
+[GblId,
+ Arity=2,
+ Str=<1L><1!P(L)>,
+ Cpr=1,
+ Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)}]
+f = \ (x :: X) (v :: Int) ->
+      case v of { GHC.Types.I# ww ->
+      case x of {
+        A -> GHC.Types.I# (GHC.Prim.+# 1# ww);
+        B -> GHC.Types.I# (GHC.Prim.+# 2# ww);
+        C -> GHC.Types.I# (GHC.Prim.+# 3# ww);
+        D -> GHC.Types.I# (GHC.Prim.+# 4# ww);
+        E -> GHC.Types.I# (GHC.Prim.+# 5# ww)
+      }
+      }
+
+
+
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index bee268bd9a..9f21bd4178 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -442,6 +442,7 @@ test('T22357',  normal, compile, ['-O'])
 #    Rule fired: SPEC/T17366 f @(Tagged tag) @_ (T17366)
 test('T17366',  normal, multimod_compile, ['T17366', '-O -v0 -ddump-rule-firings'])
 test('T17366_AR',  [grep_errmsg(r'SPEC')], multimod_compile, ['T17366_AR', '-O -v0 -ddump-rule-firings'])
+test('T22375', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds -dsuppress-unfoldings'])
 
 # One module, T21851_2.hs, has OPTIONS_GHC -ddump-simpl
 # Expecting to see $s$wwombat