Propagate evaluated-ness a bit more faithfully

This was provoked by Trac #13027.

The fix in Simplify actually cures the reported bug; see
Note [Case binder evaluated-ness] in Simplify.

The fix in CoreTidy looks like an omission that I fixed while I
was at it.

2 files changed, 31 insertions, 0 deletions

diff --git a/testsuite/tests/simplCore/should_compile/T13027.hs b/testsuite/tests/simplCore/should_compile/T13027.hs
new file mode 100644
index 0000000000..727dfc5859
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T13027.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+module T13027 (insert) where
+
+import GHC.Exts (isTrue#, reallyUnsafePtrEquality#)
+
+data Set a = Bin {-# UNPACK #-} !Size !a !(Set a) !(Set a)
+           | Tip
+
+type Size = Int
+
+insert :: Ord a => a -> Set a -> Set a
+insert = go
+  where
+    go :: Ord a => a -> Set a -> Set a
+    go !x Tip = Bin 1 x Tip Tip
+    go !x t@(Bin sz y l r) = case compare x y of
+        LT | l' `ptrEq` l -> t
+           | otherwise -> undefined -- balanceL y l' r
+           where !l' = go x l
+        GT | r' `ptrEq` r -> t
+           | otherwise -> undefined -- balanceR y l r'
+           where !r' = go x r
+        EQ | x `ptrEq` y -> t
+           | otherwise -> Bin sz x l r
+{-# INLINABLE insert #-}
+
+ptrEq :: a -> a -> Bool
+ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y)
+{-# INLINE ptrEq #-}
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 6b852fc77c..c5666c4a6c 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -254,4 +254,5 @@ test('T12603',
      normal,
      run_command,
      ['$MAKE -s --no-print-directory T12603'])
+test('T13027', normal, compile, [''])