diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/GHC/Builtin/Names.hs | 22 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Pmc.hs | 10 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Pmc/Check.hs | 81 |
3 files changed, 96 insertions, 17 deletions
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. -} |