diff options
author | Sebastian Graf <sebastian.graf@kit.edu> | 2020-09-21 14:49:56 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-09-30 02:48:27 -0400 |
commit | 3ab0d8f77ec67676de40ebe6ff7e86756e5c761e (patch) | |
tree | 9b91405f7c7ad48f7ed8ec9a1cf65dbda4e349a9 | |
parent | 8e3f00dd24936b6674d0a2322f8410125968583e (diff) | |
download | haskell-3ab0d8f77ec67676de40ebe6ff7e86756e5c761e.tar.gz |
PmCheck: Long-distance information for LocalBinds (#18626)
Now `desugarLocalBind` (formerly `desugarLet`) reasons about
* `FunBind`s that
* Have no pattern matches (so which aren't functions)
* Have a singleton match group with a single GRHS
* (which may have guards)
* and looks through trivial post-typechecking `AbsBinds` in doing so
to pick up the introduced renamings.
And desugars to `PmLet` LYG-style guards. Since GRHSs are no longer
denoted simply by `NonEmpty PmGRHS`, but also need to carry a `[PmGrd]`
for the `PmLet`s from `LocalBind`s, I added `PmGRHSs` to capture that.
Since we call out to the desugarer more often, I found that there were
superfluous warnings emitted when desugaring e.g. case expressions.
Thus, I made sure that we deactivate any warnings in the LYG desugaring
steps by the new wrapper function `noCheckDs`.
There's a regression test in `T18626`. Fixes #18626.
-rw-r--r-- | compiler/GHC/HsToCore/Pmc.hs | 39 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Pmc/Check.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Pmc/Desugar.hs | 93 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Pmc/Types.hs | 14 | ||||
-rw-r--r-- | testsuite/tests/pmcheck/should_compile/T18626.hs | 11 | ||||
-rw-r--r-- | testsuite/tests/pmcheck/should_compile/all.T | 2 |
6 files changed, 138 insertions, 26 deletions
diff --git a/compiler/GHC/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs index d621e65c4b..6a6e8175bc 100644 --- a/compiler/GHC/HsToCore/Pmc.hs +++ b/compiler/GHC/HsToCore/Pmc.hs @@ -59,6 +59,7 @@ import GHC.HsToCore.Pmc.Ppr import GHC.Types.Basic (Origin(..)) import GHC.Core (CoreExpr) import GHC.Driver.Session +import GHC.Driver.Types import GHC.Hs import GHC.Types.Id import GHC.Types.SrcLoc @@ -66,11 +67,12 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.Var (EvVar) +import GHC.Tc.Types import GHC.Tc.Utils.TcType (evVarPred) import {-# SOURCE #-} GHC.HsToCore.Expr (dsLExpr) import GHC.HsToCore.Monad import GHC.Data.Bag -import GHC.Data.IOEnv (unsafeInterleaveM) +import GHC.Data.IOEnv (updEnv, unsafeInterleaveM) import GHC.Data.OrdList import GHC.Utils.Monad (mapMaybeM) @@ -95,12 +97,22 @@ getLdiNablas = do True -> pure nablas False -> pure initNablas +-- | We need to call the Hs desugarer to get the Core of a let-binding or where +-- clause. We don't want to run the coverage checker when doing so! Efficiency +-- is one concern, but also a lack of properly set up long-distance information +-- might trigger warnings that we normally wouldn't emit. +noCheckDs :: DsM a -> DsM a +noCheckDs k = do + dflags <- getDynFlags + let dflags' = foldl' wopt_unset dflags allPmCheckWarnings + updEnv (\env -> env{env_top = (env_top env) {hsc_dflags = dflags'} }) k + -- | Check a pattern binding (let, where) for exhaustiveness. pmcPatBind :: DsMatchContext -> Id -> Pat GhcTc -> DsM () -- See Note [pmcPatBind only checks PatBindRhs] pmcPatBind ctxt@(DsMatchContext PatBindRhs loc) var p = do - missing <- getLdiNablas - pat_bind <- desugarPatBind loc var p + !missing <- getLdiNablas + pat_bind <- noCheckDs $ desugarPatBind loc var p tracePm "pmcPatBind {" (vcat [ppr ctxt, ppr var, ppr p, ppr pat_bind, ppr missing]) result <- unCA (checkPatBind pat_bind) missing tracePm "}: " (ppr (cr_uncov result)) @@ -117,8 +129,8 @@ pmcGRHSs pmcGRHSs hs_ctxt guards@(GRHSs _ grhss _) = do let combined_loc = foldl1 combineSrcSpans (map getLoc grhss) ctxt = DsMatchContext hs_ctxt combined_loc - matches <- desugarGRHSs combined_loc empty guards - missing <- getLdiNablas + !missing <- getLdiNablas + matches <- noCheckDs $ desugarGRHSs combined_loc empty guards tracePm "pmcGRHSs" (hang (vcat [ppr ctxt , text "Guards:"]) 2 @@ -126,7 +138,7 @@ pmcGRHSs hs_ctxt guards@(GRHSs _ grhss _) = do result <- unCA (checkGRHSs matches) missing tracePm "}: " (ppr (cr_uncov result)) formatReportWarnings cirbsGRHSs ctxt [] result - return (ldiGRHS <$> cr_ret result) + return (ldiGRHSs (cr_ret result)) -- | Check a list of syntactic 'Match'es (part of case, functions, etc.), each -- with a 'Pat' and one or more 'GRHSs': @@ -153,7 +165,7 @@ pmcMatches ctxt vars matches = do -- We have to force @missing@ before printing out the trace message, -- otherwise we get interleaved output from the solver. This function -- should be strict in @missing@ anyway! - !missing <- getLdiNablas + !missing <- getLdiNablas tracePm "pmcMatches {" $ hang (vcat [ppr ctxt, ppr vars, text "Matches:"]) 2 @@ -162,13 +174,13 @@ pmcMatches ctxt vars matches = do Nothing -> do -- This must be an -XEmptyCase. See Note [Checking EmptyCase] let var = only vars - empty_case <- desugarEmptyCase var + empty_case <- noCheckDs $ desugarEmptyCase var result <- unCA (checkEmptyCase empty_case) missing tracePm "}: " (ppr (cr_uncov result)) formatReportWarnings cirbsEmptyCase ctxt vars result return [] Just matches -> do - matches <- desugarMatches vars matches + matches <- noCheckDs $ desugarMatches vars matches result <- unCA (checkMatchGroup matches) missing tracePm "}: " (ppr (cr_uncov result)) formatReportWarnings cirbsMatchGroup ctxt vars result @@ -201,7 +213,10 @@ ldiMatchGroup (PmMatchGroup matches) = ldiMatch <$> matches ldiMatch :: PmMatch Post -> (Nablas, NonEmpty Nablas) ldiMatch (PmMatch { pm_pats = red, pm_grhss = grhss }) = - (rs_cov red, ldiGRHS <$> grhss) + (rs_cov red, ldiGRHSs grhss) + +ldiGRHSs :: PmGRHSs Post -> NonEmpty Nablas +ldiGRHSs (PmGRHSs { pgs_grhss = grhss }) = ldiGRHS <$> grhss ldiGRHS :: PmGRHS Post -> Nablas ldiGRHS (PmGRHS { pg_grds = red }) = rs_cov red @@ -277,8 +292,8 @@ cirbsMatch PmMatch { pm_pats = red, pm_grhss = grhss } = do $ applyWhen (not is_covered) markAllRedundant $ cirb -cirbsGRHSs :: NonEmpty (PmGRHS Post) -> DsM CIRB -cirbsGRHSs grhss = Semi.sconcat <$> traverse cirbsGRHS grhss +cirbsGRHSs :: PmGRHSs Post -> DsM CIRB +cirbsGRHSs (PmGRHSs { pgs_grhss = grhss }) = Semi.sconcat <$> traverse cirbsGRHS grhss cirbsGRHS :: PmGRHS Post -> DsM CIRB cirbsGRHS PmGRHS { pg_grds = red, pg_rhs = info } = do diff --git a/compiler/GHC/HsToCore/Pmc/Check.hs b/compiler/GHC/HsToCore/Pmc/Check.hs index 49cf79965e..f228e4471a 100644 --- a/compiler/GHC/HsToCore/Pmc/Check.hs +++ b/compiler/GHC/HsToCore/Pmc/Check.hs @@ -167,8 +167,9 @@ checkMatch :: PmMatch Pre -> CheckAction (PmMatch Post) checkMatch (PmMatch { pm_pats = GrdVec grds, pm_grhss = grhss }) = leftToRight PmMatch (checkGrds grds) (checkGRHSs grhss) -checkGRHSs :: NonEmpty (PmGRHS Pre) -> CheckAction (NonEmpty (PmGRHS Post)) -checkGRHSs = checkSequence checkGRHS +checkGRHSs :: PmGRHSs Pre -> CheckAction (PmGRHSs Post) +checkGRHSs (PmGRHSs { pgs_lcls = GrdVec lcls, pgs_grhss = grhss }) = + leftToRight PmGRHSs (checkGrds lcls) (checkSequence checkGRHS grhss) checkGRHS :: PmGRHS Pre -> CheckAction (PmGRHS Post) checkGRHS (PmGRHS { pg_grds = GrdVec grds, pg_rhs = rhs_info }) = diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs index 07b0095dd2..fa87eae8f0 100644 --- a/compiler/GHC/HsToCore/Pmc/Desugar.hs +++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs @@ -26,6 +26,7 @@ import GHC.HsToCore.Pmc.Types import GHC.HsToCore.Pmc.Utils import GHC.Core (Expr(Var,App)) import GHC.Data.FastString (unpackFS, lengthFS) +import GHC.Data.Bag (bagToList) import GHC.Driver.Session import GHC.Hs import GHC.Tc.Utils.Zonk (shortCutLit) @@ -36,6 +37,7 @@ import GHC.Builtin.Types import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Misc import GHC.Core.DataCon import GHC.Types.Var (EvVar) import GHC.Core.Coercion @@ -326,12 +328,14 @@ desugarMatch vars (L match_loc (Match { m_pats = pats, m_grhss = grhss })) = do -- tracePm "desugarMatch" (vcat [ppr pats, ppr pats', ppr grhss']) return PmMatch { pm_pats = GrdVec pats', pm_grhss = grhss' } -desugarGRHSs :: SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (NonEmpty (PmGRHS Pre)) -desugarGRHSs match_loc pp_pats grhss - = traverse (desugarLGRHS match_loc pp_pats) - . expectJust "desugarGRHSs" - . NE.nonEmpty - $ grhssGRHSs grhss +desugarGRHSs :: SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (PmGRHSs Pre) +desugarGRHSs match_loc pp_pats grhss = do + lcls <- desugarLocalBinds (grhssLocalBinds grhss) + grhss' <- traverse (desugarLGRHS match_loc pp_pats) + . expectJust "desugarGRHSs" + . NE.nonEmpty + $ grhssGRHSs grhss + return PmGRHSs { pgs_lcls = GrdVec lcls, pgs_grhss = grhss' } -- | Desugar a guarded right-hand side to a single 'GrdTree' desugarLGRHS :: SrcSpan -> SDoc -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM (PmGRHS Pre) @@ -351,7 +355,7 @@ desugarLGRHS match_loc pp_pats (L _loc (GRHS _ gs _)) = do desugarGuard :: GuardStmt GhcTc -> DsM [PmGrd] desugarGuard guard = case guard of BodyStmt _ e _ _ -> desugarBoolGuard e - LetStmt _ binds -> desugarLet (unLoc binds) + LetStmt _ binds -> desugarLocalBinds binds BindStmt _ p e -> desugarBind p e LastStmt {} -> panic "desugarGuard LastStmt" ParStmt {} -> panic "desugarGuard ParStmt" @@ -359,9 +363,39 @@ desugarGuard guard = case guard of RecStmt {} -> panic "desugarGuard RecStmt" ApplicativeStmt {} -> panic "desugarGuard ApplicativeLastStmt" --- | Desugar let-bindings -desugarLet :: HsLocalBinds GhcTc -> DsM [PmGrd] -desugarLet _binds = return [] +-- | Desugar local bindings to a bunch of 'PmLet' guards. +-- Deals only with simple @let@ or @where@ bindings without any polymorphism, +-- recursion, pattern bindings etc. +-- See Note [Long-distance information for HsLocalBinds]. +desugarLocalBinds :: LHsLocalBinds GhcTc -> DsM [PmGrd] +desugarLocalBinds (L _ (HsValBinds _ (XValBindsLR (NValBinds binds _)))) = do + concatMapM (concatMapM go . bagToList) (map snd binds) + where + go :: LHsBind GhcTc -> DsM [PmGrd] + go (L _ FunBind{fun_id = L _ x, fun_matches = mg}) + -- See Note [Long-distance information for HsLocalBinds] for why this + -- pattern match is so very specific. + | L _ [L _ Match{m_pats = [], m_grhss = grhss}] <- mg_alts mg + , GRHSs{grhssGRHSs = [L _ (GRHS _ _grds rhs)]} <- grhss = do + core_rhs <- dsLExpr rhs + return [PmLet x core_rhs] + go (L _ AbsBinds{ abs_tvs = [], abs_ev_vars = [] + , abs_exports=exports, abs_binds = binds }) = do + -- Typechecked HsLocalBinds are wrapped in AbsBinds, which carry + -- renamings. See Note [Long-distance information for HsLocalBinds] + -- for the details. + let go_export :: ABExport GhcTc -> Maybe PmGrd + go_export ABE{abe_poly = x, abe_mono = y, abe_wrap = wrap} + | isIdHsWrapper wrap + = ASSERT2(idType x `eqType` idType y, ppr x $$ ppr (idType x) $$ ppr y $$ ppr (idType y)) + Just $ PmLet x (Var y) + | otherwise + = Nothing + let exps = mapMaybe go_export exports + bs <- concatMapM go (bagToList binds) + return (exps ++ bs) + go _ = return [] +desugarLocalBinds _binds = return [] -- | Desugar a pattern guard -- @pat <- e ==> let x = e; <guards for pat <- x>@ @@ -447,4 +481,43 @@ a lot of false warnings. But we can check whether the coercion is a hole or if it is just refl, in which case we can drop it. + +Note [Long-distance information for HsLocalBinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#18626) + + f :: Int -> () + f x | y = () + where + y = True + + x :: () + x | let y = True, y = () + +Both definitions are exhaustive, but to make the necessary long-distance +connection from @y@'s binding to its use site in a guard, we have to collect +'PmLet' guards for the 'HsLocalBinds' which contain @y@'s definitions. + +In principle, we are only interested in desugaring local binds that are +'FunBind's, that + + * Have no pattern matches. If @y@ above had any patterns, it would be a + function and we can't reason about them anyway. + * Have singleton match group with a single GRHS. + Otherwise, what expression to pick in the generated guard @let y = <rhs>@? + +It turns out that desugaring type-checked local binds in this way is a bit +more complex than expected: Apparently, all bindings are wrapped in 'AbsBinds' +Nfter type-checking. See Note [AbsBinds] in "GHC.Hs.Binds". + +We make sure that there is no polymorphism in the way by checking that there +are no 'abs_tvs' or 'abs_ev_vars' (we don't reason about +@y :: forall a. Eq a => ...@) and that the exports carry no 'HsWrapper's. In +this case, the exports are a simple renaming substitution that we can capture +with 'PmLet'. Ultimately we'll hit those renamed 'FunBind's, though, which is +the whole point. + +The place to store the 'PmLet' guards for @where@ clauses (which are per +'GRHSs') is as a field of 'PmGRHSs'. For plain @let@ guards as in the guards of +@x@, we can simply add them to the 'pg_grds' field of 'PmGRHS'. -} diff --git a/compiler/GHC/HsToCore/Pmc/Types.hs b/compiler/GHC/HsToCore/Pmc/Types.hs index 793485ae39..99aeaff85e 100644 --- a/compiler/GHC/HsToCore/Pmc/Types.hs +++ b/compiler/GHC/HsToCore/Pmc/Types.hs @@ -22,7 +22,7 @@ module GHC.HsToCore.Pmc.Types ( SrcInfo(..), PmGrd(..), GrdVec(..), -- ** Guard tree language - PmMatchGroup(..), PmMatch(..), PmGRHS(..), PmPatBind(..), PmEmptyCase(..), + PmMatchGroup(..), PmMatch(..), PmGRHSs(..), PmGRHS(..), PmPatBind(..), PmEmptyCase(..), -- * Coverage Checking types RedSets (..), Precision (..), CheckResult (..), @@ -112,7 +112,13 @@ newtype PmMatchGroup p = PmMatchGroup (NonEmpty (PmMatch p)) -- | A guard tree denoting 'Match': A payload describing the pats and a bunch of -- GRHS. -data PmMatch p = PmMatch { pm_pats :: !p, pm_grhss :: !(NonEmpty (PmGRHS p)) } +data PmMatch p = PmMatch { pm_pats :: !p, pm_grhss :: !(PmGRHSs p) } + +-- | A guard tree denoting 'GRHSs': A bunch of 'PmLet' guards for local +-- bindings from the 'GRHSs's @where@ clauses and the actual list of 'GRHS'. +-- See Note [Long-distance information for HsLocalBinds] in +-- "GHC.HsToCore.Pmc.Desugar". +data PmGRHSs p = PmGRHSs { pgs_lcls :: !p, pgs_grhss :: !(NonEmpty (PmGRHS p))} -- | A guard tree denoting 'GRHS': A payload describing the grds and a 'SrcInfo' -- useful for printing out in warnings messages. @@ -149,6 +155,10 @@ instance Outputable p => Outputable (PmMatch p) where ppr (PmMatch { pm_pats = grds, pm_grhss = grhss }) = ppr grds <+> ppr grhss +instance Outputable p => Outputable (PmGRHSs p) where + ppr (PmGRHSs { pgs_lcls = _lcls, pgs_grhss = grhss }) = + ppr grhss + instance Outputable p => Outputable (PmGRHS p) where ppr (PmGRHS { pg_grds = grds, pg_rhs = rhs }) = ppr grds <+> text "->" <+> ppr rhs diff --git a/testsuite/tests/pmcheck/should_compile/T18626.hs b/testsuite/tests/pmcheck/should_compile/T18626.hs new file mode 100644 index 0000000000..c0e70de5ad --- /dev/null +++ b/testsuite/tests/pmcheck/should_compile/T18626.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -Wincomplete-patterns -fforce-recomp #-} + +module Lib where + +x :: () +x | let y = True, y = () + +f :: Int -> () +f _ | y = () + where + y = True diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T index ff56bdf0ba..e7f3667ea7 100644 --- a/testsuite/tests/pmcheck/should_compile/all.T +++ b/testsuite/tests/pmcheck/should_compile/all.T @@ -148,6 +148,8 @@ test('T18478', collect_compiler_stats('bytes allocated',10), compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns']) test('T18533', normal, compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns']) +test('T18626', normal, compile, + ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns']) test('T18572', normal, compile, ['-fwarn-incomplete-patterns -fwarn-incomplete-uni-patterns -fwarn-overlapping-patterns']) test('T18609', normal, compile, |