Commit 9d388eb8 authored by Ryan Scott's avatar Ryan Scott

Fix #15385 by using addDictsDs in matchGuards

Summary:
When coverage checking pattern-matches, we rely on the call
sites in the desugarer to populate the local dictionaries and term
evidence in scope using `addDictsDs` and `addTmCsDs`. But it turns
out that only the call site for desugaring `case` expressions was
actually doing this properly. In another part of the desugarer,
`matchGuards` (which handles pattern guards), it did not update the
local dictionaries in scope at all, leading to #15385.

Fixing this is relatively straightforward: just augment the
`BindStmt` case of `matchGuards` to use `addDictsDs` and `addTmCsDs`.
Accomplishing this took a little bit of import/export tweaking:

* We now need to export `collectEvVarsPat` from `HsPat.hs`.
* To avoid an import cycle with `Check.hs`, I moved `isTrueLHsExpr`
  from `DsGRHSs.hs` to `DsUtils.hs`, which resides lower on the
  import chain.

Test Plan: make test TEST=T15385

Reviewers: simonpj, bgamari

Reviewed By: simonpj

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #15385

Differential Revision: https://phabricator.haskell.org/D4968
parent 11de4380
...@@ -51,7 +51,7 @@ import Var (EvVar) ...@@ -51,7 +51,7 @@ import Var (EvVar)
import TyCoRep import TyCoRep
import Type import Type
import UniqSupply import UniqSupply
import DsGRHSs (isTrueLHsExpr) import DsUtils (isTrueLHsExpr)
import Maybes (expectJust) import Maybes (expectJust)
import qualified GHC.LanguageExtensions as LangExt import qualified GHC.LanguageExtensions as LangExt
......
...@@ -15,18 +15,17 @@ module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where ...@@ -15,18 +15,17 @@ module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where
import GhcPrelude import GhcPrelude
import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds ) import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )
import {-# SOURCE #-} Match ( matchSinglePat ) import {-# SOURCE #-} Match ( matchSinglePatVar )
import HsSyn import HsSyn
import MkCore import MkCore
import CoreSyn import CoreSyn
import CoreUtils (bindNonRec)
import Check (genCaseTmCs2)
import DsMonad import DsMonad
import DsUtils import DsUtils
import TysWiredIn
import PrelNames
import Type ( Type ) import Type ( Type )
import Module
import Name import Name
import Util import Util
import SrcLoc import SrcLoc
...@@ -118,9 +117,18 @@ matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do ...@@ -118,9 +117,18 @@ matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do
-- body expression in hand -- body expression in hand
matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do
match_result <- matchGuards stmts ctx rhs rhs_ty let upat = unLoc pat
dicts = collectEvVarsPat upat
match_var <- selectMatchVar upat
tm_cs <- genCaseTmCs2 (Just bind_rhs) [upat] [match_var]
match_result <- addDictsDs dicts $
addTmCsDs tm_cs $
-- See Note [Type and Term Equality Propagation] in Check
matchGuards stmts ctx rhs rhs_ty
core_rhs <- dsLExpr bind_rhs core_rhs <- dsLExpr bind_rhs
matchSinglePat core_rhs (StmtCtxt ctx) pat rhs_ty match_result match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty
match_result
pure $ adjustMatchResult (bindNonRec match_var core_rhs) match_result'
matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt" matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt"
matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt" matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt"
...@@ -131,35 +139,6 @@ matchGuards (ApplicativeStmt {} : _) _ _ _ = ...@@ -131,35 +139,6 @@ matchGuards (ApplicativeStmt {} : _) _ _ _ =
matchGuards (XStmtLR {} : _) _ _ _ = matchGuards (XStmtLR {} : _) _ _ _ =
panic "matchGuards XStmtLR" panic "matchGuards XStmtLR"
isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
-- Returns Just {..} if we're sure that the expression is True
-- I.e. * 'True' datacon
-- * 'otherwise' Id
-- * Trivial wappings of these
-- The arguments to Just are any HsTicks that we have found,
-- because we still want to tick then, even it they are always evaluated.
isTrueLHsExpr (L _ (HsVar _ (L _ v))) | v `hasKey` otherwiseIdKey
|| v `hasKey` getUnique trueDataConId
= Just return
-- trueDataConId doesn't have the same unique as trueDataCon
isTrueLHsExpr (L _ (HsConLikeOut _ con))
| con `hasKey` getUnique trueDataCon = Just return
isTrueLHsExpr (L _ (HsTick _ tickish e))
| Just ticks <- isTrueLHsExpr e
= Just (\x -> do wrapped <- ticks x
return (Tick tickish wrapped))
-- This encodes that the result is constant True for Hpc tick purposes;
-- which is specifically what isTrueLHsExpr is trying to find out.
isTrueLHsExpr (L _ (HsBinTick _ ixT _ e))
| Just ticks <- isTrueLHsExpr e
= Just (\x -> do e <- ticks x
this_mod <- getModule
return (Tick (HpcTick this_mod ixT) e))
isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e
isTrueLHsExpr _ = Nothing
{- {-
Should {\em fail} if @e@ returns @D@ Should {\em fail} if @e@ returns @D@
\begin{verbatim} \begin{verbatim}
......
...@@ -37,7 +37,8 @@ module DsUtils ( ...@@ -37,7 +37,8 @@ module DsUtils (
mkSelectorBinds, mkSelectorBinds,
selectSimpleMatchVarL, selectMatchVars, selectMatchVar, selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang,
isTrueLHsExpr
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -966,3 +967,32 @@ addBang = go ...@@ -966,3 +967,32 @@ addBang = go
-- Should we bring the extension value over? -- Should we bring the extension value over?
BangPat _ _ -> lp BangPat _ _ -> lp
_ -> L l (BangPat noExt lp) _ -> L l (BangPat noExt lp)
isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
-- Returns Just {..} if we're sure that the expression is True
-- I.e. * 'True' datacon
-- * 'otherwise' Id
-- * Trivial wappings of these
-- The arguments to Just are any HsTicks that we have found,
-- because we still want to tick then, even it they are always evaluated.
isTrueLHsExpr (L _ (HsVar _ (L _ v))) | v `hasKey` otherwiseIdKey
|| v `hasKey` getUnique trueDataConId
= Just return
-- trueDataConId doesn't have the same unique as trueDataCon
isTrueLHsExpr (L _ (HsConLikeOut _ con))
| con `hasKey` getUnique trueDataCon = Just return
isTrueLHsExpr (L _ (HsTick _ tickish e))
| Just ticks <- isTrueLHsExpr e
= Just (\x -> do wrapped <- ticks x
return (Tick tickish wrapped))
-- This encodes that the result is constant True for Hpc tick purposes;
-- which is specifically what isTrueLHsExpr is trying to find out.
isTrueLHsExpr (L _ (HsBinTick _ ixT _ e))
| Just ticks <- isTrueLHsExpr e
= Just (\x -> do e <- ticks x
this_mod <- getModule
return (Tick (HpcTick this_mod ixT) e))
isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e
isTrueLHsExpr _ = Nothing
...@@ -28,8 +28,8 @@ matchSimply ...@@ -28,8 +28,8 @@ matchSimply
-> CoreExpr -> CoreExpr
-> DsM CoreExpr -> DsM CoreExpr
matchSinglePat matchSinglePatVar
:: CoreExpr :: Id
-> HsMatchContext Name -> HsMatchContext Name
-> LPat GhcTc -> LPat GhcTc
-> Type -> Type
......
...@@ -34,7 +34,7 @@ module HsPat ( ...@@ -34,7 +34,7 @@ module HsPat (
patNeedsParens, parenthesizePat, patNeedsParens, parenthesizePat,
isIrrefutableHsPat, isIrrefutableHsPat,
collectEvVarsPats, collectEvVarsPat, collectEvVarsPats,
pprParendLPat, pprConArgs pprParendLPat, pprConArgs
) where ) where
......
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wincomplete-patterns #-}
module T15385 where
import Data.Type.Equality
data T a where
TInt :: T Int
TBool :: T Bool
f1, f2 :: a :~: Int -> T a -> ()
f1 eq t
| Refl <- eq
= case t of
TInt -> ()
f2 eq t
= if | Refl <- eq
-> case t of
TInt -> ()
...@@ -44,25 +44,27 @@ test('T11276', compiler_stats_num_field('bytes allocated', ...@@ -44,25 +44,27 @@ test('T11276', compiler_stats_num_field('bytes allocated',
test('T11303b', compiler_stats_num_field('bytes allocated', test('T11303b', compiler_stats_num_field('bytes allocated',
[(wordsize(64), 54373936, 10)] [(wordsize(64), 54373936, 10)]
# 2018-07-14: 54373936 INITIAL # 2018-07-14: 54373936 INITIAL
), compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M1G -RTS']) ), compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M1G -RTS'])
test('T11374', compiler_stats_num_field('bytes allocated', test('T11374', compiler_stats_num_field('bytes allocated',
[(wordsize(64), 280144864, 10)] [(wordsize(64), 280144864, 10)]
# 2018-07-14: 280144864 INITIAL # 2018-07-14: 280144864 INITIAL
), compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M1G -RTS']) ), compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M1G -RTS'])
test('T11195', compiler_stats_num_field('bytes allocated', test('T11195', compiler_stats_num_field('bytes allocated',
[(wordsize(64), 7852567480, 10)] [(wordsize(64), 7852567480, 10)]
# 2018-07-14: 7852567480 INITIAL # 2018-07-14: 7852567480 INITIAL
), compile, ['-package ghc -fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M2G -RTS']) ), compile, ['-package ghc -fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M2G -RTS'])
test('T11984', normal, compile, test('T11984', normal, compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns']) ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
test('T14086', normal, compile, test('T14086', normal, compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns']) ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
test('T14098', normal, compile, test('T14098', normal, compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns']) ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
test('T15385', normal, compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
# Other tests # Other tests
test('pmc001', [], compile, test('pmc001', [], compile,
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment