[Git][ghc/ghc][wip/T18049] PmCheck: Pick up `EvVar`s bound in `HsWrapper`s for long-distance info
Sebastian Graf
gitlab at gitlab.haskell.org
Mon Apr 27 19:16:23 UTC 2020
Sebastian Graf pushed to branch wip/T18049 at Glasgow Haskell Compiler / GHC
Commits:
d866e118 by Sebastian Graf at 2020-04-27T21:16:16+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.
Fixes #18049.
- - - - -
6 changed files:
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Expr.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
=====================================
@@ -280,7 +280,13 @@ 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
+ _ -> -- Uncommenting the following line leads to a 300%
+ -- compile-time allocation regression in T3064, see
+ -- !3087. Unless we find a testcase that motivates this
+ -- change, I'm not willing to think of a complicated
+ -- work-around.
+ -- addTyCsDs FromSource (hsWrapDictBinders co_fn) $
+ dsExpr e
-- See Note [Detecting forced eta expansion]
; wrap' <- dsHsWrapper co_fn
; dflags <- getDynFlags
=====================================
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
@@ -1043,10 +1043,14 @@ locallyExtendPmDelta ext k = getPmDeltas >>= ext >>= \deltas -> do
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))
+-- | 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/-/commit/d866e11829e223523d526e2bc998d6df22c36a2e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d866e11829e223523d526e2bc998d6df22c36a2e
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/20200427/7d6ab6a1/attachment-0001.html>
More information about the ghc-commits
mailing list