From e571eda75f979e315ff87997e58ed99eb9d874c9 Mon Sep 17 00:00:00 2001 From: Sebastian Graf Date: Tue, 23 Feb 2021 16:19:34 +0100 Subject: Pmc: Implement `considerAccessible` (#18610) Consider (`T18610`): ```hs f :: Bool -> Int f x = case (x, x) of (True, True) -> 1 (False, False) -> 2 (True, False) -> 3 -- Warning: Redundant ``` The third clause will be flagged as redundant. Nevertheless, the programmer might intend to keep the clause in order to avoid bitrot. After this patch, the programmer can write ```hs g :: Bool -> Int g x = case (x, x) of (True, True) -> 1 (False, False) -> 2 (True, False) | GHC.Exts.considerAccessible -> 3 -- No warning ``` And won't be bothered any longer. See also `Note [considerAccessible]` and the updated entries in the user's guide. Fixes #18610 and #19228. --- compiler/GHC/Builtin/Names.hs | 22 +++--- compiler/GHC/HsToCore/Pmc.hs | 10 ++- compiler/GHC/HsToCore/Pmc/Check.hs | 81 ++++++++++++++++++++++ docs/users_guide/9.2.1-notes.rst | 17 +++-- docs/users_guide/using-warnings.rst | 28 ++++++++ libraries/base/GHC/Exts.hs | 30 +++++++- testsuite/tests/pmcheck/should_compile/T18610.hs | 66 ++++++++++++++++++ .../tests/pmcheck/should_compile/T18610.stderr | 17 +++++ testsuite/tests/pmcheck/should_compile/all.T | 2 + 9 files changed, 248 insertions(+), 25 deletions(-) create mode 100644 testsuite/tests/pmcheck/should_compile/T18610.hs create mode 100644 testsuite/tests/pmcheck/should_compile/T18610.stderr diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index 40af981264..2dc6e47493 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 651f37f909..3292372e6e 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 3ffd51fe7a..10d8574093 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 9812279849..918f8ebae8 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 a9995268ea..3c09d4c141 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 d1ca1cfff8..106c7e9ea6 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 0000000000..fbde93138e --- /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 0000000000..7f6a2dfe67 --- /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 b922696fae..5245862851 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, -- cgit v1.2.1