From 57c391c463f26b7025df9b340ad98416cff1d2b2 Mon Sep 17 00:00:00 2001
From: Sebastian Graf <sgraf1337@gmail.com>
Date: Tue, 5 Dec 2023 11:19:56 +0100
Subject: [PATCH] Cpr: Turn an assertion into a check to deal with some dead
code (#23862)
See the new `Note [Dead code may contain type confusions]`.
Fixes #23862.
---
compiler/GHC/Core/Opt/CprAnal.hs | 43 +++++++++++++++++--
.../tests/cpranal/should_compile/T23862.hs | 19 ++++++++
.../cpranal/should_compile/T23862.stderr | 18 ++++++++
testsuite/tests/cpranal/should_compile/all.T | 2 +
4 files changed, 79 insertions(+), 3 deletions(-)
create mode 100755 testsuite/tests/cpranal/should_compile/T23862.hs
create mode 100644 testsuite/tests/cpranal/should_compile/T23862.stderr
diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs
index 0f2dc248410d..9d83e3d85969 100644
--- a/compiler/GHC/Core/Opt/CprAnal.hs
+++ b/compiler/GHC/Core/Opt/CprAnal.hs
@@ -270,11 +270,11 @@ cprAnalAlt
cprAnalAlt env scrut_ty (Alt con bndrs rhs)
= (rhs_ty, Alt con bndrs rhs')
where
+ ids = filter isId bndrs
env_alt
| DataAlt dc <- con
- , let ids = filter isId bndrs
, CprType arity cpr <- scrut_ty
- , assert (arity == 0 ) True
+ , arity == 0 -- See Note [Dead code may contain type confusions]
= case unpackConFieldsCpr dc cpr of
AllFieldsSame field_cpr
| let sig = mkCprSig 0 field_cpr
@@ -283,7 +283,7 @@ cprAnalAlt env scrut_ty (Alt con bndrs rhs)
| let sigs = zipWith (mkCprSig . idArity) ids field_cprs
-> extendSigEnvList env (zipEqual "cprAnalAlt" ids sigs)
| otherwise
- = env
+ = extendSigEnvAllSame env ids topCprSig
(rhs_ty, rhs') = cprAnal env_alt rhs
--
@@ -430,6 +430,43 @@ cprFix orig_env orig_pairs
(id', rhs', env') = cprAnalBind env id rhs
{-
+Note [Dead code may contain type confusions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In T23862, we have a nested case match that looks like this
+
+ data CheckSingleton (check :: Bool) where
+ Checked :: CheckSingleton True
+ Unchecked :: CheckSingleton False
+ data family Result (check :: Bool) a
+ data instance Result True a = CheckedResult a
+ newtype instance Result True a = UncheckedResult a
+
+ case m () of Checked co1 ->
+ case m () of Unchecked co2 ->
+ case ((\_ -> True)
+ |> .. UncheckedResult ..
+ |> sym co2
+ |> co1) :: Result True (Bool -> Bool) of
+ CheckedResult f -> CheckedResult (f True)
+
+Clearly, the innermost case is dead code, because the `Checked` and `Unchecked`
+cases are apart.
+However, both constructors introduce mutually contradictory coercions `co1` and
+`co2` along which GHC generates a type confusion:
+
+ 1. (\_ -> True) :: Bool -> Bool
+ 2. newtype coercion UncheckedResult (\_ -> True) :: Result False (Bool -> Bool)
+ 3. |> ... sym co1 ... :: Result check (Bool -> Bool)
+ 4. |> ... co2 ... :: Result True (Bool -> Bool)
+
+Note that we started with a function, injected into `Result` via a newtype
+instance and then match on it with a datatype instance.
+
+We have to handle this case gracefully in `cprAnalAlt`, where for the innermost
+case we see a `DataAlt` for `CheckedResult`, yet have a scrutinee type that
+abstracts the function `(\_ -> True)` with arity 1.
+In this case, don't pretend we know anything about the fields of `CheckedResult`!
+
Note [The OPAQUE pragma and avoiding the reboxing of results]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider:
diff --git a/testsuite/tests/cpranal/should_compile/T23862.hs b/testsuite/tests/cpranal/should_compile/T23862.hs
new file mode 100755
index 000000000000..1ae2c9e30cb6
--- /dev/null
+++ b/testsuite/tests/cpranal/should_compile/T23862.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+
+module T23862 where
+
+data family Result (check :: Bool) a
+data instance Result True a = CheckedResult a
+newtype instance Result False a = UncheckedResult a
+
+data CheckSingleton (check :: Bool) where
+ Checked :: CheckSingleton True
+ Unchecked :: CheckSingleton False
+
+app :: (() -> CheckSingleton check) -> Result check Bool
+app m = case (m (), m ()) of
+ (Checked, Unchecked)
+ | CheckedResult x <- UncheckedResult (\_ -> True)
+ -> CheckedResult (x True)
diff --git a/testsuite/tests/cpranal/should_compile/T23862.stderr b/testsuite/tests/cpranal/should_compile/T23862.stderr
new file mode 100644
index 000000000000..31f1107ccfbc
--- /dev/null
+++ b/testsuite/tests/cpranal/should_compile/T23862.stderr
@@ -0,0 +1,18 @@
+
+T23862.hs:17:12: warning: [GHC-40564] [-Winaccessible-code (in -Wdefault)]
+ • Inaccessible code in
+ a pattern with constructor: Unchecked :: CheckSingleton False,
+ in a case alternative
+ Couldn't match type ‘True’ with ‘False’
+ • In the pattern: Unchecked
+ In the pattern: (Checked, Unchecked)
+ In a case alternative:
+ (Checked, Unchecked)
+ | CheckedResult x <- UncheckedResult (\ _ -> True)
+ -> CheckedResult (x True)
+
+T23862.hs:18:6: warning: [GHC-94210] [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match has inaccessible right hand side
+ In a case alternative:
+ (Checked, Unchecked) | CheckedResult x <- UncheckedResult
+ (\ _ -> True) -> ...
diff --git a/testsuite/tests/cpranal/should_compile/all.T b/testsuite/tests/cpranal/should_compile/all.T
index f33b43fe3a67..5a100c19bd15 100644
--- a/testsuite/tests/cpranal/should_compile/all.T
+++ b/testsuite/tests/cpranal/should_compile/all.T
@@ -22,3 +22,5 @@ test('T18401', [ grep_errmsg(r'^T18401\.\S+ ::') ], compile, ['-ddump-simpl -dsu
test('T18824', [ grep_errmsg(r'JoinId[^\n]*Cpr') ], compile, ['-ddump-exitify -dppr-cols=1000 -dsuppress-uniques'])
test('T20539', [], compile, ['']) # simply should not crash
+
+test('T23862', [], compile, ['']) # simply should not crash
--
GitLab