[Git][ghc/ghc][wip/T18049] 2 commits: PmCheck: Only call checkSingle if we would report warnings
Sebastian Graf
gitlab at gitlab.haskell.org
Wed Apr 29 15:11:08 UTC 2020
Sebastian Graf pushed to branch wip/T18049 at Glasgow Haskell Compiler / GHC
Commits:
5775abc4 by Sebastian Graf at 2020-04-29T16:47:59+02:00
PmCheck: Only call checkSingle if we would report warnings
- - - - -
d246cb9a by Sebastian Graf at 2020-04-29T17:10:22+02:00
PmCheck: Pick up `EvVar`s bound in `HsWrapper`s for long-distance info
`HsWrapper`s introduce evidence bindings through `WpEvLam` and `WpLet`
which the pattern-match coverage checker should be made aware of.
Failing to do so caused #18049, where the resulting impreciseness of
imcompleteness warnings seemingly contradicted with
`-Winaccessible-code`.
The solution is simple: Collect all the evidence binders of an
`HsWrapper` and add it to the ambient `Deltas` before desugaring
the wrapped expression.
But that means we pick up many more evidence bindings, even when they
wrap around code without a single pattern match to check! That regressed
`T3064` by over 300%, so now we are adding long-distance info lazily
through judicious use of `unsafeInterleaveIO`.
Fixes #18049.
- - - - -
7 changed files:
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/PmCheck.hs
- compiler/GHC/Tc/Types/Evidence.hs
- + testsuite/tests/pmcheck/should_compile/T18049.hs
- testsuite/tests/pmcheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -33,7 +33,7 @@ import {-# SOURCE #-} GHC.HsToCore.Match ( matchWrapper )
import GHC.HsToCore.Monad
import GHC.HsToCore.GuardedRHSs
import GHC.HsToCore.Utils
-import GHC.HsToCore.PmCheck ( needToRunPmCheck, addTyCsDs, checkGuardMatches )
+import GHC.HsToCore.PmCheck ( addTyCsDs, checkGuardMatches )
import GHC.Hs -- lots of things
import GHC.Core -- lots of things
@@ -145,12 +145,20 @@ dsHsBind dflags (VarBind { var_id = var
else []
; return (force_var, [core_bind]) }
-dsHsBind dflags b@(FunBind { fun_id = L _ fun
+dsHsBind dflags b@(FunBind { fun_id = L loc fun
, fun_matches = matches
, fun_ext = co_fn
, fun_tick = tick })
- = do { (args, body) <- matchWrapper
- (mkPrefixFunRhs (noLoc $ idName fun))
+ = do { (args, body) <- addTyCsDs FromSource (hsWrapDictBinders co_fn) $
+ -- FromSource might not be accurate (we don't have any
+ -- origin annotations for things in this module), but at
+ -- worst we do superfluous calls to the pattern match
+ -- oracle.
+ -- addTyCsDs: Add type evidence to the refinement type
+ -- predicate of the coverage checker
+ -- See Note [Type and Term Equality Propagation] in PmCheck
+ matchWrapper
+ (mkPrefixFunRhs (L loc (idName fun)))
Nothing matches
; core_wrap <- dsHsWrapper co_fn
; let body' = mkOptTickBox tick body
@@ -189,15 +197,7 @@ dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_exports = exports
, abs_ev_binds = ev_binds
, abs_binds = binds, abs_sig = has_sig })
- = do { ds_binds <- applyWhen (needToRunPmCheck dflags FromSource)
- -- FromSource might not be accurate, but at worst
- -- we do superfluous calls to the pattern match
- -- oracle.
- -- addTyCsDs: push type constraints deeper
- -- for inner pattern match check
- -- See Check, Note [Type and Term Equality Propagation]
- (addTyCsDs (listToBag dicts))
- (dsLHsBinds binds)
+ = do { ds_binds <- addTyCsDs FromSource (listToBag dicts) (dsLHsBinds binds)
; ds_ev_binds <- dsTcEvBinds_s ev_binds
@@ -206,7 +206,6 @@ dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
-
-----------------------
dsAbsBinds :: DynFlags
-> [TyVar] -> [EvVar] -> [ABExport GhcTc]
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -32,7 +32,7 @@ import GHC.HsToCore.ListComp
import GHC.HsToCore.Utils
import GHC.HsToCore.Arrows
import GHC.HsToCore.Monad
-import GHC.HsToCore.PmCheck ( checkGuardMatches )
+import GHC.HsToCore.PmCheck ( addTyCsDs, checkGuardMatches )
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Core.FamInstEnv( topNormaliseType )
@@ -280,7 +280,8 @@ dsExpr hswrap@(XExpr (HsWrap co_fn e))
HsConLikeOut _ (RealDataCon dc) -> return $ varToCoreExpr (dataConWrapId dc)
XExpr (HsWrap _ _) -> pprPanic "dsExpr: HsWrap inside HsWrap" (ppr hswrap)
HsPar _ _ -> pprPanic "dsExpr: HsPar inside HsWrap" (ppr hswrap)
- _ -> dsExpr e
+ _ -> addTyCsDs FromSource (hsWrapDictBinders co_fn) $
+ dsExpr e
-- See Note [Detecting forced eta expansion]
; wrap' <- dsHsWrapper co_fn
; dflags <- getDynFlags
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -859,8 +859,10 @@ matchSinglePatVar var ctx pat ty match_result
do { dflags <- getDynFlags
; locn <- getSrcSpanDs
- -- Pattern match check warnings
- ; checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat)
+ -- Pattern match check warnings
+ ; if isMatchContextPmChecked dflags FromSource ctx
+ then checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat)
+ else pure ()
; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]
, eqn_orig = FromSource
=====================================
compiler/GHC/HsToCore/PmCheck.hs
=====================================
@@ -14,7 +14,7 @@ Pattern Matching Coverage Checking.
module GHC.HsToCore.PmCheck (
-- Checking and printing
checkSingle, checkMatches, checkGuardMatches,
- needToRunPmCheck, isMatchContextPmChecked,
+ isMatchContextPmChecked,
-- See Note [Type and Term Equality Propagation]
addTyCsDs, addScrutTmCs
@@ -45,7 +45,7 @@ import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Types.Var (EvVar)
import GHC.Core.Coercion
-import GHC.Tc.Types.Evidence ( HsWrapper(..), isIdHsWrapper )
+import GHC.Tc.Types.Evidence (HsWrapper(..), isIdHsWrapper)
import GHC.Tc.Utils.TcType (evVarPred)
import {-# SOURCE #-} GHC.HsToCore.Expr (dsExpr, dsLExpr, dsSyntaxExpr)
import {-# SOURCE #-} GHC.HsToCore.Binds (dsHsWrapper)
@@ -53,6 +53,7 @@ import GHC.HsToCore.Utils (selectMatchVar)
import GHC.HsToCore.Match.Literal (dsLit, dsOverLit)
import GHC.HsToCore.Monad
import GHC.Data.Bag
+import GHC.Data.IOEnv (unsafeInterleaveM)
import GHC.Data.OrdList
import GHC.Core.TyCo.Rep
import GHC.Core.Type
@@ -1033,20 +1034,30 @@ Functions `addScrutTmCs' is responsible for generating
these constraints.
-}
+-- | Locally update 'dsl_deltas' with the given action, but defer evaluation
+-- with 'unsafeInterleaveM' in order not to do unnecessary work.
locallyExtendPmDelta :: (Deltas -> DsM Deltas) -> DsM a -> DsM a
-locallyExtendPmDelta ext k = getPmDeltas >>= ext >>= \deltas -> do
- inh <- isInhabited deltas
- -- If adding a constraint would lead to a contradiction, don't add it.
- -- See @Note [Recovering from unsatisfiable pattern-matching constraints]@
- -- for why this is done.
- if inh
- then updPmDeltas deltas k
- else k
-
--- | Add in-scope type constraints
-addTyCsDs :: Bag EvVar -> DsM a -> DsM a
-addTyCsDs ev_vars =
- locallyExtendPmDelta (\deltas -> addPmCtsDeltas deltas (PmTyCt . evVarPred <$> ev_vars))
+locallyExtendPmDelta ext k = do
+ deltas <- getPmDeltas
+ deltas' <- unsafeInterleaveM $ do
+ deltas' <- ext deltas
+ inh <- isInhabited deltas
+ -- If adding a constraint would lead to a contradiction, don't add it.
+ -- See @Note [Recovering from unsatisfiable pattern-matching constraints]@
+ -- for why this is done.
+ if inh
+ then pure deltas'
+ else pure deltas
+ updPmDeltas deltas' k
+
+-- | Add in-scope type constraints if the coverage checker might run and then
+-- run the given action.
+addTyCsDs :: Origin -> Bag EvVar -> DsM a -> DsM a
+addTyCsDs origin ev_vars m = do
+ dflags <- getDynFlags
+ applyWhen (needToRunPmCheck dflags origin)
+ (locallyExtendPmDelta (\deltas -> addPmCtsDeltas deltas (PmTyCt . evVarPred <$> ev_vars)))
+ m
-- | Add equalities for the scrutinee to the local 'DsM' environment when
-- checking a case expression:
=====================================
compiler/GHC/Tc/Types/Evidence.hs
=====================================
@@ -10,7 +10,7 @@ module GHC.Tc.Types.Evidence (
(<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams,
mkWpLams, mkWpLet, mkWpCastN, mkWpCastR, collectHsWrapBinders,
mkWpFun, idHsWrapper, isIdHsWrapper, isErasableHsWrapper,
- pprHsWrapper,
+ pprHsWrapper, hsWrapDictBinders,
-- * Evidence bindings
TcEvBinds(..), EvBindsVar(..),
@@ -370,6 +370,25 @@ isErasableHsWrapper = go
go WpTyApp{} = True
go WpLet{} = False
+hsWrapDictBinders :: HsWrapper -> Bag DictId
+-- Collects the given dict Ids, bound by the wrapper,
+-- that scope over the "hole" in the wrapper
+hsWrapDictBinders wrap = go wrap emptyBag
+ where
+ go WpHole acc = acc
+ go (w1 `WpCompose` w2) acc = go w1 (go w2 acc)
+ go (WpFun _ w2 _ _) acc = go w2 acc
+ go (WpCast {}) acc = acc
+ go (WpEvLam dict_id) acc = dict_id `consBag` acc
+ go (WpEvApp {}) acc = acc
+ go (WpTyLam {}) acc = acc
+ go (WpTyApp {}) acc = acc
+ go (WpLet binds) acc = go_binds binds `unionBags` acc
+
+ go_binds (EvBinds bs) = mapBag eb_lhs bs
+ go_binds (TcEvBinds ebv) = pprPanic "hsWrapperDictBinds" (ppr ebv)
+ -- Should only be applied post zonking
+
collectHsWrapBinders :: HsWrapper -> ([Var], HsWrapper)
-- Collect the outer lambda binders of a HsWrapper,
-- stopping as soon as you get to a non-lambda binder
=====================================
testsuite/tests/pmcheck/should_compile/T18049.hs
=====================================
@@ -0,0 +1,29 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# OPTIONS_GHC -Wincomplete-patterns -fforce-recomp #-}
+module Bug where
+
+import Data.Kind
+
+data SBool :: Bool -> Type where
+ SFalse :: SBool False
+ STrue :: SBool True
+
+f :: SBool b
+ -> (b ~ True => SBool b -> r)
+ -> (b ~ False => SBool b -> r)
+ -> r
+f x t f =
+ case x of
+ SFalse -> f x
+ STrue -> t x
+
+g :: forall b. SBool b -> ()
+g x = f x
+ (\x' ->
+ case x' of
+ -- SFalse -> ()
+ STrue -> ())
+ (\_ -> ())
=====================================
testsuite/tests/pmcheck/should_compile/all.T
=====================================
@@ -118,6 +118,8 @@ test('T17977', collect_compiler_stats('bytes allocated',10), compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
test('T17977b', collect_compiler_stats('bytes allocated',10), compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
+test('T18049', normal, compile,
+ ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
# Other tests
test('pmc001', [], compile,
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d866e11829e223523d526e2bc998d6df22c36a2e...d246cb9a88523f247e8a96cc3b710cadc3c59e2d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d866e11829e223523d526e2bc998d6df22c36a2e...d246cb9a88523f247e8a96cc3b710cadc3c59e2d
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200429/7f181b5c/attachment-0001.html>
More information about the ghc-commits
mailing list