diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs index 0f2dc248410d8991171a04548adefac5e01d1d00..9d83e3d8596972cd488c0386657a7a817f460ed5 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 0000000000000000000000000000000000000000..1ae2c9e30cb6c66a744c531b7d9e2b4f2dce5558 --- /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 0000000000000000000000000000000000000000..31f1107ccfbcaa57d855c3e644b88d644f3d5a6c --- /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 f33b43fe3a678db7e3e33eb9aee1e7ff35654493..5a100c19bd151bccd72e29cc32954c44a9ebe7ae 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