diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index 40af981264090bf738b0728cb169519eb12b22e0..2dc6e47493d1f82dd5e33f71510965a44da30ada 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -319,6 +319,7 @@ basicKnownKeyNames
-- GHC Extensions
groupWithName,
+ considerAccessibleName,
-- Strings and lists
unpackCStringName, unpackCStringUtf8Name,
@@ -1122,8 +1123,9 @@ alternativeClassKey = mkPreludeMiscIdUnique 754
-- Functions for GHC extensions
-groupWithName :: Name
-groupWithName = varQual gHC_EXTS (fsLit "groupWith") groupWithIdKey
+groupWithName, considerAccessibleName :: Name
+groupWithName = varQual gHC_EXTS (fsLit "groupWith") groupWithIdKey
+considerAccessibleName = varQual gHC_EXTS (fsLit "considerAccessible") considerAccessibleIdKey
-- Random PrelBase functions
fromStringName, otherwiseIdName, foldrName, buildName, augmentName,
@@ -2362,15 +2364,13 @@ inlineIdKey, noinlineIdKey :: Unique
inlineIdKey = mkPreludeMiscIdUnique 120
-- see below
-mapIdKey, groupWithIdKey, dollarIdKey :: Unique
-mapIdKey = mkPreludeMiscIdUnique 121
-groupWithIdKey = mkPreludeMiscIdUnique 122
-dollarIdKey = mkPreludeMiscIdUnique 123
-
-coercionTokenIdKey :: Unique
-coercionTokenIdKey = mkPreludeMiscIdUnique 124
-
-noinlineIdKey = mkPreludeMiscIdUnique 125
+mapIdKey, groupWithIdKey, dollarIdKey, coercionTokenIdKey, considerAccessibleIdKey :: Unique
+mapIdKey = mkPreludeMiscIdUnique 121
+groupWithIdKey = mkPreludeMiscIdUnique 122
+dollarIdKey = mkPreludeMiscIdUnique 123
+coercionTokenIdKey = mkPreludeMiscIdUnique 124
+noinlineIdKey = mkPreludeMiscIdUnique 125
+considerAccessibleIdKey = mkPreludeMiscIdUnique 126
rationalToFloatIdKey, rationalToDoubleIdKey :: Unique
rationalToFloatIdKey = mkPreludeMiscIdUnique 130
diff --git a/compiler/GHC/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs
index 651f37f909790be7cc9ddcbad90058be9d002a73..3292372e6ec8891d1b4ed5f645643af7d938c276 100644
--- a/compiler/GHC/HsToCore/Pmc.hs
+++ b/compiler/GHC/HsToCore/Pmc.hs
@@ -238,10 +238,6 @@ instance Semigroup CIRB where
instance Monoid CIRB where
mempty = CIRB mempty mempty mempty mempty
-markAllRedundant :: CIRB -> CIRB
-markAllRedundant CIRB { cirb_cov = cov, cirb_inacc = inacc, cirb_red = red } =
- mempty { cirb_red = cov Semi.<> inacc Semi.<> red }
-
-- See Note [Determining inaccessible clauses]
ensureOneNotRedundant :: CIRB -> CIRB
ensureOneNotRedundant ci = case ci of
@@ -279,12 +275,14 @@ cirbsMatchGroup (PmMatchGroup matches) =
cirbsMatch :: PmMatch Post -> DsM CIRB
cirbsMatch PmMatch { pm_pats = red, pm_grhss = grhss } = do
- (is_covered, may_diverge, red_bangs) <- testRedSets red
+ (_is_covered, may_diverge, red_bangs) <- testRedSets red
+ -- Don't look at is_covered: If it is True, all children are redundant anyway,
+ -- unless there is a 'considerAccessible', which may break that rule
+ -- intentionally. See Note [considerAccessible] in "GHC.HsToCore.Pmc.Check".
cirb <- cirbsGRHSs grhss
pure $ addRedundantBangs red_bangs
-- See Note [Determining inaccessible clauses]
$ applyWhen may_diverge ensureOneNotRedundant
- $ applyWhen (not is_covered) markAllRedundant
$ cirb
cirbsGRHSs :: PmGRHSs Post -> DsM CIRB
diff --git a/compiler/GHC/HsToCore/Pmc/Check.hs b/compiler/GHC/HsToCore/Pmc/Check.hs
index 3ffd51fe7a25c867a55ad138663f679ae323aa5f..10d85740934792a3ea47e074293a5a732c921332 100644
--- a/compiler/GHC/HsToCore/Pmc/Check.hs
+++ b/compiler/GHC/HsToCore/Pmc/Check.hs
@@ -26,6 +26,7 @@ module GHC.HsToCore.Pmc.Check (
import GHC.Prelude
+import GHC.Builtin.Names ( hasKey, considerAccessibleIdKey, trueDataConKey )
import GHC.HsToCore.Monad ( DsM )
import GHC.HsToCore.Pmc.Types
import GHC.HsToCore.Pmc.Utils
@@ -124,6 +125,13 @@ checkGrd grd = CA $ \inc -> case grd of
pure CheckResult { cr_ret = RedSets { rs_cov = matched, rs_div = div, rs_bangs = bangs }
, cr_uncov = mempty
, cr_approx = Precise }
+ -- See point (3) of Note [considerAccessible]
+ PmCon x (PmAltConLike con) _ _ _
+ | x `hasKey` considerAccessibleIdKey
+ , con `hasKey` trueDataConKey
+ -> pure CheckResult { cr_ret = emptyRedSets { rs_cov = initNablas }
+ , cr_uncov = mempty
+ , cr_approx = Precise }
-- Con: Fall through on x ≠K and refine with x ~ K ys and type info
PmCon x con tvs dicts args -> do
!div <- if isPmAltConMatchStrict con
@@ -269,4 +277,77 @@ Guards are an extreme example in this regard, with #11195 being a particularly
dreadful example: Since their RHS are often pretty much unique, we split on a
variable (the one representing the RHS) that doesn't occur anywhere else in the
program, so we don't actually get useful information out of that split!
+
+Note [considerAccessible]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (T18610)
+
+ f :: Bool -> Int
+ f x = case (x, x) of
+ (True, True) -> 1
+ (False, False) -> 2
+ (True, False) -> 3 -- Warning: Redundant
+
+The third case is detected as redundant. But it may be the intent of the
+programmer to keep the dead code, in order for it not to bitrot or to support
+debugging scenarios. But there is no way to communicate that to the
+pattern-match checker! The only way is to deactivate pattern-match checking
+whole-sale, which is quite annoying. Hence, we define in "GHC.Exts":
+
+ considerAccessible = True
+
+'considerAccessible' is treated specially by the pattern-match checker in that a
+guard with it as the scrutinee expression will keep its parent clause alive:
+
+ g :: Bool -> Int
+ g x = case (x, x) of
+ (True, True) -> 1
+ (False, False) -> 2
+ (True, False) | GHC.Exts.considerAccessible -> 3 -- No warning
+
+The key bits of the implementation are:
+
+ 1. Its definition is recognised as known-key (see "GHC.Builtin.Names").
+ 2. After "GHC.HsToCore.Pmc.Desugar", the guard will end up as a 'PmCon', where
+ the match var is the known-key 'considerAccessible' and the constructor
+ against which it matches is 'True'.
+ 3. We recognise the 'PmCon' in 'GHC.HsToCore.Check.checkGrd' and inflate the
+ incoming set of values for all guards downstream to the unconstrained
+ 'initNablas' set, e.g. /all/ values.
+ (The set of values that falls through that particular guard is empty, as
+ matching 'considerAccessible' against 'True' can't fail.)
+
+Note that 'considerAccessible' breaks the invariant that incoming sets of values
+reaching syntactic children are subsets of that of the syntactic ancestor:
+A whole match, like that of the third clause of the example, might have no
+incoming value, but its single RHS has incoming values because of (3).
+
+That means the 'is_covered' flag computed in 'GHC.HsToCore.Pmc.cirbsMatch'
+is irrelevant and should not be used to flag all children as redundant (which is
+what we used to do).
+
+We achieve great benefits with a very simple implementation.
+There are caveats, though:
+
+ (A) Putting potentially failing guards /after/ the
+ 'considerAccessible' guard might lead to weird check results, e.g.,
+
+ h :: Bool -> Int
+ h x = case (x, x) of
+ (True, True) -> 1
+ (False, False) -> 2
+ (True, False) | GHC.Exts.considerAccessible, False <- x -> 3
+ -- Warning: Not matched: (_, _)
+
+ That *is* fixable, although we would pay with a much more complicated
+ implementation.
+ (B) If the programmer puts a 'considerAccessible' marker on an accessible
+ clause, the checker doesn't warn about it. E.g.,
+
+ f :: Bool -> Int
+ f True | considerAccessible = 0
+ f False = 1
+
+ will not emit any warning whatsoever. We could implement code that warns
+ here, but it wouldn't be as simple as it is now.
-}
diff --git a/docs/users_guide/9.2.1-notes.rst b/docs/users_guide/9.2.1-notes.rst
index 981227984920c2a750ef1939a2797d626b3a5899..918f8ebae8a53064e4ae7de6032a92b07deff750 100644
--- a/docs/users_guide/9.2.1-notes.rst
+++ b/docs/users_guide/9.2.1-notes.rst
@@ -114,15 +114,12 @@ Runtime system
Moreover, we now correctly account for the size of the array, meaning that
space lost to fragmentation is no longer counted as live data.
-- The :rts-flag:`-h` flag has been deprecated, use either :rts-flag:`-hc` or
- :rts-flag:`-hT` explicitly, as appropriate.
+
- The ``-xt`` RTS flag has been removed. Now STACK and TSO closures are always
included in heap profiles. Tooling can choose to filter out these closure types
- if necessary.
+` if necessary.
-``ghc-prim`` library
-~~~~~~~~~~~~~~~~~~~~
- ``Void#`` is now a type synonym for the unboxed tuple ``(# #)``.
Code using ``Void#`` now has to enable :extension:`UnboxedTuples`.
@@ -203,3 +200,13 @@ Runtime system
- On POSIX, ``System.IO.openFile`` can no longer leak a file descriptor if it
is interrupted by an asynchronous exception (#19114, #19115).
+
+- There's a new binding ``GHC.Exts.considerAccessible``. It's equivalent to
+ ``True`` and allows the programmer to turn off pattern-match redundancy
+ warnings for particular clauses, like the third one here ::
+
+ g :: Bool -> Int
+ g x = case (x, x) of
+ (True, True) -> 1
+ (False, False) -> 2
+ (True, False) | considerAccessible -> 3 -- No warning!
diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst
index a9995268ea5fb33e538308106fc613b364d7b115..3c09d4c14163159ce1d2369118a4a86637f9fc97 100644
--- a/docs/users_guide/using-warnings.rst
+++ b/docs/users_guide/using-warnings.rst
@@ -1235,6 +1235,34 @@ of ``-W(no-)*``.
second pattern overlaps it. More often than not, redundant patterns
is a programmer mistake/error, so this option is enabled by default.
+ If the programmer is dead set of keeping a redundant clause,
+ for example to prevent bitrot, they can make use of a guard
+ scrutinising ``GHC.Exts.considerAccessible`` to prevent the
+ checker from flagging the parent clause as redundant: ::
+
+ g :: String -> Int
+ g [] = 0
+ g (_:xs) = 1
+ g "2" | considerAccessible = 2 -- No warning!
+
+ Note that ``considerAccessible`` should come as the last statement of
+ the guard in order not to impact the results of the checker. E.g., if
+ you write ::
+
+ h :: Bool -> Int
+ h x = case (x, x) of
+ (True, True) -> 1
+ (False, False) -> 2
+ (True, False) | considerAccessible, False <- x -> 3
+
+ The pattern-match checker takes you by your word, will conclude
+ that ``False <- x`` might fail and warn that the pattern-match
+ is inexhaustive. Put ``considerAccessible`` last to avoid such
+ confusions.
+
+ Note that due to technical limitations, ``considerAccessible`` will not
+ suppress :ghc-flag:`-Winaccessible-code` warnings.
+
.. ghc-flag:: -Winaccessible-code
:shortdesc: warn about inaccessible code
:type: dynamic
diff --git a/libraries/base/GHC/Exts.hs b/libraries/base/GHC/Exts.hs
index d1ca1cfff825f7d9685d4d1e4c12ba69d2ee4dca..106c7e9ea6fd83099bcfd07fd0e1168fd58b6c2f 100755
--- a/libraries/base/GHC/Exts.hs
+++ b/libraries/base/GHC/Exts.hs
@@ -71,7 +71,7 @@ module GHC.Exts
breakpoint, breakpointCond,
-- * Ids with special behaviour
- inline, noinline, lazy, oneShot, SPEC (..),
+ inline, noinline, lazy, oneShot, considerAccessible, SPEC (..),
-- * Running 'RealWorld' state thread
runRW#,
@@ -213,8 +213,8 @@ class IsList l where
fromList :: [Item l] -> l
-- | The 'fromListN' function takes the input list's length and potentially
- -- uses it to construct the structure @l@ more efficiently compared to
- -- 'fromList'. If the given number does not equal to the input list's length
+ -- uses it to construct the structure @l@ more efficiently compared to
+ -- 'fromList'. If the given number does not equal to the input list's length
-- the behaviour of 'fromListN' is not specified.
--
-- prop> fromListN (length xs) xs == fromList xs
@@ -315,3 +315,27 @@ resizeSmallMutableArray# arr0 szNew a s0 =
(# s2, arr1 #) -> case copySmallMutableArray# arr0 0# arr1 0# szOld s2 of
s3 -> (# s3, arr1 #)
else (# s1, arr0 #)
+
+-- | Semantically, @considerAccessible = True@. But it has special meaning
+-- to the pattern-match checker, which will never flag the clause in which
+-- 'considerAccessible' occurs as a guard as redundant or inaccessible.
+-- Example:
+--
+-- > case (x, x) of
+-- > (True, True) -> 1
+-- > (False, False) -> 2
+-- > (True, False) -> 3 -- Warning: redundant
+--
+-- The pattern-match checker will warn here that the third clause is redundant.
+-- It will stop doing so if the clause is adorned with 'considerAccessible':
+--
+-- > case (x, x) of
+-- > (True, True) -> 1
+-- > (False, False) -> 2
+-- > (True, False) | considerAccessible -> 3 -- No warning
+--
+-- Put 'considerAccessible' as the last statement of the guard to avoid get
+-- confusing results from the pattern-match checker, which takes \"consider
+-- accessible\" by word.
+considerAccessible :: Bool
+considerAccessible = True
diff --git a/testsuite/tests/pmcheck/should_compile/T18610.hs b/testsuite/tests/pmcheck/should_compile/T18610.hs
new file mode 100644
index 0000000000000000000000000000000000000000..fbde93138e9c95e07aa30c6afaa008d756f7a3df
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T18610.hs
@@ -0,0 +1,66 @@
+{-# OPTIONS_GHC -Wincomplete-patterns -fforce-recomp #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE BangPatterns #-}
+
+module T18610 where
+
+import GHC.Exts
+import Data.Type.Equality
+
+f :: Bool -> Int
+f x = case (x, x) of
+ (True, True) -> 1
+ (False, False) -> 2
+ (True, False) -> 3 -- Warning: redundant
+
+g :: Bool -> Int
+g x = case (x, x) of
+ (True, True) -> 1
+ (False, False) -> 2
+ (True, False) | considerAccessible -> 3 -- No warning!
+
+h :: Bool -> Int
+h x = case (x, x) of
+ (True, True) -> 1
+ (False, False) -> 2
+ (True, False) | considerAccessible, False <- x -> 3
+ -- Warning: Not exhaustive. A non-severe leaking implementation detail of
+ -- Note [considerAccessible]
+
+--
+-- All the following bindings should not emit PMC warnings
+--
+
+-- | Clause 1 is not redundant, but has inaccessible RHS. The marker should
+-- prevent a warning.
+i :: () -> Int
+i () | False, considerAccessible = 1
+i _ = 2
+
+-- | Clause 1 is accessible with or without the marker. It has no
+-- impact on checking the other equations.
+j :: Bool -> Int
+j x = case (x, x) of
+ (True, True) | considerAccessible -> 1
+ (False, False) -> 2
+
+-- | The 'Refl' makes the second clause inaccessible (even a bang would do).
+-- The marker prevents a warning. Unfortunately, it has no effect on
+-- @-Winaccessible-code@.
+k :: Int :~: Bool -> Bool -> Int
+k _ False = 1
+k Refl _ | considerAccessible = 2
+
+-- | Compared to 'g', the marked inaccessible clause comes first. It has no
+-- impact on checking the other equations.
+l :: Bool -> Int
+l x = case (x, x) of
+ (True, False) | considerAccessible -> 1 -- No warning!
+ (True, True) -> 2
+ (False, False) -> 3
+
+-- | Warning that the second GRHS is redundant would be unsound here.
+m :: Int -> Int
+m x | False <- considerAccessible = 1
+ | otherwise = 2 -- Not redundant!
diff --git a/testsuite/tests/pmcheck/should_compile/T18610.stderr b/testsuite/tests/pmcheck/should_compile/T18610.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..7f6a2dfe678117b290d89fe7fb3f6a6ab154c435
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T18610.stderr
@@ -0,0 +1,17 @@
+
+T18610.hs:15:3: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In a case alternative: (True, False) -> ...
+
+T18610.hs:24:7: warning: [-Wincomplete-patterns (in -Wextra)]
+ Pattern match(es) are non-exhaustive
+ In a case alternative:
+ Patterns of type ‘(Bool, Bool)’ not matched: (_, _)
+
+T18610.hs:53:3: warning: [-Winaccessible-code (in -Wdefault)]
+ • Couldn't match type ‘Bool’ with ‘Int’
+ Inaccessible code in
+ a pattern with constructor: Refl :: forall {k} (a :: k). a :~: a,
+ in an equation for ‘k’
+ • In the pattern: Refl
+ In an equation for ‘k’: k Refl _ | considerAccessible = 2
diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T
index b922696faec9aaeaa7f1c215fa20cba3de97a007..5245862851ce66dbd89ae3433cfd89b660277b74 100644
--- a/testsuite/tests/pmcheck/should_compile/all.T
+++ b/testsuite/tests/pmcheck/should_compile/all.T
@@ -154,6 +154,8 @@ test('T18572', normal, compile,
['-fwarn-incomplete-patterns -fwarn-incomplete-uni-patterns -fwarn-overlapping-patterns'])
test('T18609', normal, compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
+test('T18610', normal, compile,
+ ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
test('T18670', normal, compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
test('T18708', normal, compile,