[Git][ghc/ghc][master] 2 commits: codeGen: Don't discard live case binders in unsafeEqualityProof logic

[Marge Bot]

 Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
9a7462fb by Ben Gamari at 2020-06-14T15:35:23-04:00
codeGen: Don't discard live case binders in unsafeEqualityProof logic

Previously CoreToStg would unconditionally discard cases of the form:

    case unsafeEqualityProof of wild { _ -> rhs }

and rather replace the whole thing with `rhs`. However, in some cases
(see #18227) the case binder is still live, resulting in unbound
occurrences in `rhs`. Fix this by only discarding the case if the case
binder is dead.

Fixes #18227.

- - - - -
e4137c48 by Ben Gamari at 2020-06-14T15:35:23-04:00
testsuite: Add tests for #18227

T18227A is the original issue which gave rise to the ticket and depends
upon bytestring. T18227B is a minimized reproducer.

- - - - -


5 changed files:

- compiler/GHC/CoreToStg.hs
- libraries/base/Unsafe/Coerce.hs
- + testsuite/tests/codeGen/should_compile/T18227A.hs
- + testsuite/tests/codeGen/should_compile/T18227B.hs
- testsuite/tests/codeGen/should_compile/all.T


Changes:

=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -435,7 +435,10 @@ coreToStgExpr e0@(Case scrut bndr _ alts) = do
     let stg = StgCase scrut2 bndr (mkStgAltType bndr alts) alts2
     -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
     case scrut2 of
-      StgApp id [] | idName id == unsafeEqualityProofName ->
+      StgApp id [] | idName id == unsafeEqualityProofName
+                   , isDeadBinder bndr ->
+        -- We can only discard the case if the case-binder is dead
+        -- It usually is, but see #18227
         case alts2 of
           [(_, [_co], rhs)] ->
             return rhs


=====================================
libraries/base/Unsafe/Coerce.hs
=====================================
@@ -106,6 +106,11 @@ several ways
     unsafeEqualityProof to f.  As (U5) says, it is implemented as
     UnsafeRefl so all is good.
 
+    NB: Don't discard the case if the case-binder is used
+           case unsafeEqualityProof of wild_xx { UnsafeRefl ->
+           ...wild_xx...
+        That rarely happens, but see #18227.
+
 (U3) In GHC.CoreToStg.Prep.cpeRhsE, if we see
        let x = case unsafeEqualityProof ... of
                  UnsafeRefl -> K e


=====================================
testsuite/tests/codeGen/should_compile/T18227A.hs
=====================================
@@ -0,0 +1,6 @@
+module T18227A (kilter) where
+import Data.ByteString.Internal
+
+kilter :: ByteString -> IO ByteString
+kilter ps@(PS x _ _) = createAndTrim 1 $ const $ pure 1
+


=====================================
testsuite/tests/codeGen/should_compile/T18227B.hs
=====================================
@@ -0,0 +1,16 @@
+-- N.B. These warnings only cause noise in stderr.
+{-# OPTIONS_GHC -Wno-overlapping-patterns -Wno-inaccessible-code #-}
+{-# LANGUAGE GADTs #-}
+
+module T18227B where
+
+import Unsafe.Coerce
+
+test1 :: UnsafeEquality Int Char -> IO ()
+test1 hi = print "hello"
+{-# NOINLINE test1 #-}
+
+test2 :: IO ()
+test2 =
+  case unsafeEqualityProof :: UnsafeEquality Int Char of
+    proof at UnsafeRefl -> test1 proof


=====================================
testsuite/tests/codeGen/should_compile/all.T
=====================================
@@ -89,3 +89,5 @@ test('T14373d', [],
 
 test('T17648', normal, makefile_test, [])
 test('T17904', normal, compile, ['-O'])
+test('T18227A', normal, compile, [''])
+test('T18227B', normal, compile, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c0e6dee99242eff08420176a36d77b715972f1f2...e4137c486a3df66b49395beea7efc6e200cc9bac

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c0e6dee99242eff08420176a36d77b715972f1f2...e4137c486a3df66b49395beea7efc6e200cc9bac
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200614/a5567b05/attachment-0001.html>