Commit 28f951ed authored by Georgios Karachalias's avatar Georgios Karachalias Committed by Ben Gamari

Overhaul the Overhauled Pattern Match Checker

Overhaul the Overhauled Pattern Match Checker

* Changed the representation of Value Set Abstractions. Instead of
using a prefix tree, we now use a list of Value Vector Abstractions.
The set of constraints Delta for every Value Vector Abstraction is the
oracle state so that we solve everything only once.

* Instead of doing everything lazily, we prune at once (and in general
everything is much stricter). Hence, an example written with pattern
guards is checked in almost the same time as the equivalent with
pattern matching.

* Do not store the covered and the divergent sets at all. Since what we
only need is a yes/no (does this clause cover anything? Does it force
any thunk?) We just keep a boolean for each.

* Removed flags `-Wtoo-many-guards` and `-ffull-guard-reasoning`.
Replaced with `fmax-pmcheck-iterations=n`. Still debatable what should
the default `n` be.

* When a guard is for sure not going to contribute anything, we treat
it as such: The oracle is not called and cases `CGuard`, `UGuard` and
`DGuard` from the paper are not happening at all (the generation of a
fresh variable, the unfolding of the pattern list etc.). his combined
with the above seems to be enough to drop the memory increase for test
T783 down to 18.7%.

* Do not export function `dsPmWarn` (it is now called directly from
within `checkSingle` and `checkMatches`).

* Make `PmExprVar` hold a `Name` instead of an `Id`. The term oracle
does not handle type information so using `Id` was a waste of
time/space.

* Added testcases T11195, T11303b (data families) and T11374

The patch addresses at least the following:
Trac #11195, #11276, #11303, #11374, #11162

Test Plan: validate

Reviewers: goldfire, bgamari, hvr, austin

Subscribers: simonpj, thomie

Differential Revision: https://phabricator.haskell.org/D1795
parent db121b2e
This diff is collapsed.
......@@ -34,6 +34,9 @@ module DsMonad (
-- Getting and setting EvVars and term constraints in local environment
getDictsDs, addDictsDs, getTmCsDs, addTmCsDs,
-- Iterations for pm checking
incrCheckPmIterDs, resetPmIterDs,
-- Warnings
DsWarning, warnDs, failWithDs, discardWarningsDs,
......@@ -146,10 +149,12 @@ initDs :: HscEnv
initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside
= do { msg_var <- newIORef (emptyBag, emptyBag)
; static_binds_var <- newIORef []
; pm_iter_var <- newIORef 0
; let dflags = hsc_dflags hsc_env
(ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env
fam_inst_env msg_var
static_binds_var
pm_iter_var
; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
loadDAP $
......@@ -225,11 +230,12 @@ initDsTc thing_inside
; msg_var <- getErrsVar
; dflags <- getDynFlags
; static_binds_var <- liftIO $ newIORef []
; pm_iter_var <- liftIO $ newIORef 0
; let type_env = tcg_type_env tcg_env
rdr_env = tcg_rdr_env tcg_env
fam_inst_env = tcg_fam_inst_env tcg_env
ds_envs = mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
msg_var static_binds_var
msg_var static_binds_var pm_iter_var
; setEnvs ds_envs thing_inside
}
......@@ -258,8 +264,8 @@ initTcDsForSolver thing_inside
mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> IORef Messages -> IORef [(Fingerprint, (Id, CoreExpr))]
-> (DsGblEnv, DsLclEnv)
mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var static_binds_var
-> IORef Int -> (DsGblEnv, DsLclEnv)
mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var static_binds_var pmvar
= let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
......@@ -272,10 +278,11 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var static_binds_var
, ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"
, ds_static_binds = static_binds_var
}
lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
, dsl_loc = real_span
, dsl_dicts = emptyBag
, dsl_tm_cs = emptyBag
lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
, dsl_loc = real_span
, dsl_dicts = emptyBag
, dsl_tm_cs = emptyBag
, dsl_pm_iter = pmvar
}
in (gbl_env, lcl_env)
......@@ -355,6 +362,24 @@ addTmCsDs :: Bag SimpleEq -> DsM a -> DsM a
addTmCsDs tm_cs
= updLclEnv (\env -> env { dsl_tm_cs = unionBags tm_cs (dsl_tm_cs env) })
-- | Check that we have not done more iterations
-- than we are supposed to and inrease the counter
-- | Increase the counter for elapsed pattern match check iterations.
-- If the current counter is already over the limit, fail
incrCheckPmIterDs :: DsM ()
incrCheckPmIterDs = do
env <- getLclEnv
cnt <- readTcRef (dsl_pm_iter env)
max_iters <- maxPmCheckIterations <$> getDynFlags
if cnt >= max_iters
then failM
else updTcRef (dsl_pm_iter env) (+1)
-- | Reset the counter for pattern match check iterations to zero
resetPmIterDs :: DsM ()
resetPmIterDs = do { env <- getLclEnv; writeTcRef (dsl_pm_iter env) 0 }
getSrcSpanDs :: DsM SrcSpan
getSrcSpanDs = do { env <- getLclEnv
; return (RealSrcSpan (dsl_loc env)) }
......
......@@ -694,21 +694,9 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
when (isAnyPmCheckEnabled dflags (DsMatchContext ctxt locn)) $ do
-- Count the number of guards that can fail
guards <- computeNoGuards matches
let simplify = not (gopt Opt_FullGuardReasoning dflags)
&& (guards > maximum_failing_guards)
-- See Note [Type and Term Equality Propagation]
addTmCsDs (genCaseTmCs1 mb_scr new_vars) $
dsPmWarn dflags (DsMatchContext ctxt locn) $
checkMatches simplify new_vars matches
when (not (gopt Opt_FullGuardReasoning dflags)
&& wopt Opt_WarnTooManyGuards dflags
&& guards > maximum_failing_guards)
(warnManyGuards (DsMatchContext ctxt locn))
checkMatches dflags (DsMatchContext ctxt locn) new_vars matches
; result_expr <- handleWarnings $
matchEquations ctxt new_vars eqns_info rhs_ty
......@@ -777,7 +765,7 @@ matchSinglePat (Var var) ctx pat ty match_result
; locn <- getSrcSpanDs
; let pat' = getMaybeStrictPat dflags pat
-- pattern match check warnings
; dsPmWarn dflags (DsMatchContext ctx locn) (checkSingle var pat')
; checkSingle dflags (DsMatchContext ctx locn) var pat'
; match [var] ty
[EqnInfo { eqn_pats = [pat'], eqn_rhs = match_result }] }
......
......@@ -7,7 +7,7 @@ Haskell expressions (as used by the pattern matching checker) and utilities.
{-# LANGUAGE CPP #-}
module PmExpr (
PmExpr(..), PmLit(..), SimpleEq, ComplexEq, eqPmLit,
PmExpr(..), PmLit(..), SimpleEq, ComplexEq, toComplex, eqPmLit,
truePmExpr, falsePmExpr, isTruePmExpr, isFalsePmExpr, isNotPmExprOther,
lhsExprToPmExpr, hsExprToPmExpr, substComplexEq, filterComplex,
pprPmExprWithParens, runPmPprM
......@@ -17,12 +17,13 @@ module PmExpr (
import HsSyn
import Id
import Name
import NameSet
import DataCon
import TysWiredIn
import Outputable
import Util
import SrcLoc
import VarSet
import Data.Maybe (mapMaybe)
import Data.List (groupBy, sortBy, nubBy)
......@@ -50,7 +51,7 @@ refer to variables that are otherwise substituted away.
-- ** Types
-- | Lifted expressions for pattern match checking.
data PmExpr = PmExprVar Id
data PmExpr = PmExprVar Name
| PmExprCon DataCon [PmExpr]
| PmExprLit PmLit
| PmExprEq PmExpr PmExpr -- Syntactic equality
......@@ -140,6 +141,10 @@ nubPmLit = nubBy eqPmLit
type SimpleEq = (Id, PmExpr) -- We always use this orientation
type ComplexEq = (PmExpr, PmExpr)
-- | Lift a `SimpleEq` to a `ComplexEq`
toComplex :: SimpleEq -> ComplexEq
toComplex (x,e) = (PmExprVar (idName x), e)
-- | Expression `True'
truePmExpr :: PmExpr
truePmExpr = PmExprCon trueDataCon []
......@@ -193,7 +198,7 @@ isConsDataCon con = consDataCon == con
-- | We return a boolean along with the expression. Hence, if substitution was
-- a no-op, we know that the expression still cannot progress.
substPmExpr :: Id -> PmExpr -> PmExpr -> (PmExpr, Bool)
substPmExpr :: Name -> PmExpr -> PmExpr -> (PmExpr, Bool)
substPmExpr x e1 e =
case e of
PmExprVar z | x == z -> (e1, True)
......@@ -208,7 +213,7 @@ substPmExpr x e1 e =
-- | Substitute in a complex equality. We return (Left eq) if the substitution
-- affected the equality or (Right eq) if nothing happened.
substComplexEq :: Id -> PmExpr -> ComplexEq -> Either ComplexEq ComplexEq
substComplexEq :: Name -> PmExpr -> ComplexEq -> Either ComplexEq ComplexEq
substComplexEq x e (ex, ey)
| bx || by = Left (ex', ey')
| otherwise = Right (ex', ey')
......@@ -224,7 +229,7 @@ lhsExprToPmExpr (L _ e) = hsExprToPmExpr e
hsExprToPmExpr :: HsExpr Id -> PmExpr
hsExprToPmExpr (HsVar x) = PmExprVar (unLoc x)
hsExprToPmExpr (HsVar x) = PmExprVar (idName (unLoc x))
hsExprToPmExpr (HsOverLit olit) = PmExprLit (PmOLit False olit)
hsExprToPmExpr (HsLit lit) = PmExprLit (PmSLit lit)
......@@ -312,7 +317,7 @@ Check.hs) to be more precice.
-- -----------------------------------------------------------------------------
-- ** Transform residual constraints in appropriate form for pretty printing
type PmNegLitCt = (Id, (SDoc, [PmLit]))
type PmNegLitCt = (Name, (SDoc, [PmLit]))
filterComplex :: [ComplexEq] -> [PmNegLitCt]
filterComplex = zipWith rename nameList . map mkGroup
......@@ -342,19 +347,19 @@ filterComplex = zipWith rename nameList . map mkGroup
runPmPprM :: PmPprM a -> [PmNegLitCt] -> (a, [(SDoc,[PmLit])])
runPmPprM m lit_env = (result, mapMaybe is_used lit_env)
where
(result, (_lit_env, used)) = runState m (lit_env, emptyVarSet)
(result, (_lit_env, used)) = runState m (lit_env, emptyNameSet)
is_used (x,(name, lits))
| elemVarSet x used = Just (name, lits)
| elemNameSet x used = Just (name, lits)
| otherwise = Nothing
type PmPprM a = State ([PmNegLitCt], IdSet) a
type PmPprM a = State ([PmNegLitCt], NameSet) a
-- (the first part of the state is read only. make it a reader?)
addUsed :: Id -> PmPprM ()
addUsed x = modify (\(negated, used) -> (negated, extendVarSet used x))
addUsed :: Name -> PmPprM ()
addUsed x = modify (\(negated, used) -> (negated, extendNameSet used x))
checkNegation :: Id -> PmPprM (Maybe SDoc) -- the clean name if it is negated
checkNegation :: Name -> PmPprM (Maybe SDoc) -- the clean name if it is negated
checkNegation x = do
negated <- gets fst
return $ case lookup x negated of
......
......@@ -10,14 +10,14 @@ module TmOracle (
-- re-exported from PmExpr
PmExpr(..), PmLit(..), SimpleEq, ComplexEq, PmVarEnv, falsePmExpr,
canDiverge, eqPmLit, filterComplex, isNotPmExprOther, runPmPprM,
pprPmExprWithParens, lhsExprToPmExpr, hsExprToPmExpr,
eqPmLit, filterComplex, isNotPmExprOther, runPmPprM, lhsExprToPmExpr,
hsExprToPmExpr, pprPmExprWithParens,
-- the term oracle
tmOracle, TmState, initialTmState,
tmOracle, TmState, initialTmState, solveOneEq, extendSubst, canDiverge,
-- misc.
exprDeepLookup, pmLitType, flattenPmVarEnv
toComplex, exprDeepLookup, pmLitType, flattenPmVarEnv
) where
#include "HsVersions.h"
......@@ -25,6 +25,7 @@ module TmOracle (
import PmExpr
import Id
import Name
import TysWiredIn
import Type
import HsLit
......@@ -43,7 +44,7 @@ import qualified Data.Map as Map
-}
-- | The type of substitutions.
type PmVarEnv = Map.Map Id PmExpr
type PmVarEnv = Map.Map Name PmExpr
-- | The environment of the oracle contains
-- 1. A Bool (are there any constraints we cannot handle? (PmExprOther)).
......@@ -52,7 +53,7 @@ type TmOracleEnv = (Bool, PmVarEnv)
-- | Check whether a constraint (x ~ BOT) can succeed,
-- given the resulting state of the term oracle.
canDiverge :: Id -> TmState -> Bool
canDiverge :: Name -> TmState -> Bool
canDiverge x (standby, (_unhandled, env))
-- If the variable seems not evaluated, there is a possibility for
-- constraint x ~ BOT to be satisfiable.
......@@ -66,11 +67,11 @@ canDiverge x (standby, (_unhandled, env))
| otherwise = False
where
isForcedByEq :: Id -> ComplexEq -> Bool
isForcedByEq :: Name -> ComplexEq -> Bool
isForcedByEq y (e1, e2) = varIn y e1 || varIn y e2
-- | Check whether a variable is in the free variables of an expression
varIn :: Id -> PmExpr -> Bool
varIn :: Name -> PmExpr -> Bool
varIn x e = case e of
PmExprVar y -> x == y
PmExprCon _ es -> any (x `varIn`) es
......@@ -131,7 +132,7 @@ solveComplexEq solver_state@(standby, (unhandled, env)) eq@(e1, e2) = case eq of
_ -> Just (standby, (True, env)) -- I HATE CATCH-ALLS
-- | Extend the substitution and solve the (possibly updated) constraints.
extendSubstAndSolve :: Id -> PmExpr -> TmState -> Maybe TmState
extendSubstAndSolve :: Name -> PmExpr -> TmState -> Maybe TmState
extendSubstAndSolve x e (standby, (unhandled, env))
= foldlM solveComplexEq new_incr_state (map simplifyComplexEq changed)
where
......@@ -142,6 +143,19 @@ extendSubstAndSolve x e (standby, (unhandled, env))
(changed, unchanged) = partitionWith (substComplexEq x e) standby
new_incr_state = (unchanged, (unhandled, Map.insert x e env))
-- | When we know that a variable is fresh, we do not actually have to
-- check whether anything changes, we know that nothing does. Hence,
-- `extendSubst` simply extends the substitution, unlike what
-- `extendSubstAndSolve` does.
extendSubst :: Id -> PmExpr -> TmState -> TmState
extendSubst y e (standby, (unhandled, env))
| isNotPmExprOther simpl_e
= (standby, (unhandled, Map.insert x simpl_e env))
| otherwise = (standby, (True, env))
where
x = idName y
simpl_e = fst $ simplifyPmExpr $ exprDeepLookup env e
-- | Simplify a complex equality.
simplifyComplexEq :: ComplexEq -> ComplexEq
simplifyComplexEq (e1, e2) = (fst $ simplifyPmExpr e1, fst $ simplifyPmExpr e2)
......@@ -204,7 +218,7 @@ applySubstComplexEq :: PmVarEnv -> ComplexEq -> ComplexEq
applySubstComplexEq env (e1,e2) = (exprDeepLookup env e1, exprDeepLookup env e2)
-- | Apply an (un-flattened) substitution to a variable.
varDeepLookup :: PmVarEnv -> Id -> PmExpr
varDeepLookup :: PmVarEnv -> Name -> PmExpr
varDeepLookup env x
| Just e <- Map.lookup x env = exprDeepLookup env e -- go deeper
| otherwise = PmExprVar x -- terminal
......
{-# LANGUAGE CPP, ScopedTypeVariables, MagicHash, UnboxedTuples #-}
#if __GLASGOW_HASKELL__ > 710
{-# OPTIONS_GHC -ffull-guard-reasoning #-}
#endif
-----------------------------------------------------------------------------
--
......
......@@ -531,9 +531,6 @@ data GeneralFlag
-- safe haskell flags
| Opt_DistrustAllPackages
| Opt_PackageTrust
-- pm checking with guards
| Opt_FullGuardReasoning
deriving (Eq, Show, Enum)
data WarningFlag =
......@@ -555,7 +552,6 @@ data WarningFlag =
| Opt_WarnMissingLocalSigs
| Opt_WarnNameShadowing
| Opt_WarnOverlappingPatterns
| Opt_WarnTooManyGuards
| Opt_WarnTypeDefaults
| Opt_WarnMonomorphism
| Opt_WarnUnusedTopBinds
......@@ -645,6 +641,7 @@ data DynFlags = DynFlags {
debugLevel :: Int, -- ^ How much debug information to produce
simplPhases :: Int, -- ^ Number of simplifier phases
maxSimplIterations :: Int, -- ^ Max simplifier iterations
maxPmCheckIterations :: Int, -- ^ Max no iterations for pm checking
ruleCheck :: Maybe String,
strictnessBefore :: [Int], -- ^ Additional demand analysis
......@@ -1438,6 +1435,7 @@ defaultDynFlags mySettings =
debugLevel = 0,
simplPhases = 2,
maxSimplIterations = 4,
maxPmCheckIterations = 10000000,
ruleCheck = Nothing,
maxRelevantBinds = Just 6,
simplTickFactor = 100,
......@@ -2632,6 +2630,8 @@ dynamic_flags = [
(intSuffix (\n d -> d{ simplPhases = n }))
, defFlag "fmax-simplifier-iterations"
(intSuffix (\n d -> d{ maxSimplIterations = n }))
, defFlag "fmax-pmcheck-iterations"
(intSuffix (\n d -> d{ maxPmCheckIterations = n }))
, defFlag "fsimpl-tick-factor"
(intSuffix (\n d -> d{ simplTickFactor = n }))
, defFlag "fspec-constr-threshold"
......@@ -2980,7 +2980,6 @@ wWarningFlags = [
flagSpec "orphans" Opt_WarnOrphans,
flagSpec "overflowed-literals" Opt_WarnOverflowedLiterals,
flagSpec "overlapping-patterns" Opt_WarnOverlappingPatterns,
flagSpec "too-many-guards" Opt_WarnTooManyGuards,
flagSpec "missed-specialisations" Opt_WarnMissedSpecs,
flagSpec "all-missed-specialisations" Opt_WarnAllMissedSpecs,
flagSpec' "safe" Opt_WarnSafe setWarnSafe,
......@@ -3117,8 +3116,7 @@ fFlags = [
flagSpec "unbox-strict-fields" Opt_UnboxStrictFields,
flagSpec "vectorisation-avoidance" Opt_VectorisationAvoidance,
flagSpec "vectorise" Opt_Vectorise,
flagSpec "worker-wrapper" Opt_WorkerWrapper,
flagSpec "full-guard-reasoning" Opt_FullGuardReasoning
flagSpec "worker-wrapper" Opt_WorkerWrapper
]
-- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@
......
-- | Constants describing the DWARF format. Most of this simply
-- mirrors /usr/include/dwarf.h.
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ > 710
{-# OPTIONS_GHC -ffull-guard-reasoning #-}
#endif
module Dwarf.Constants where
......
......@@ -338,7 +338,8 @@ data DsLclEnv = DsLclEnv {
dsl_meta :: DsMetaEnv, -- Template Haskell bindings
dsl_loc :: RealSrcSpan, -- To put in pattern-matching error msgs
dsl_dicts :: Bag EvVar, -- Constraints from GADT pattern-matching
dsl_tm_cs :: Bag SimpleEq
dsl_tm_cs :: Bag SimpleEq,
dsl_pm_iter :: IORef Int -- no iterations for pmcheck
}
-- Inside [| |] brackets, the desugarer looks
......
......@@ -2,9 +2,7 @@
{-# LANGUAGE CPP #-}
-- This module used to take 10GB of memory to compile with the new
-- (Nov '15) pattern-match check. In order to be able to compile it,
-- do not enable -ffull-guard-reasoning. Instead, simplify the guards
-- (default behaviour when guards are too many).
-- (Nov '15) pattern-match checker.
module OptCoercion ( optCoercion, checkAxInstCo ) where
......
......@@ -287,15 +287,6 @@ Compiler
warns in the case of unused term-level patterns. Both flags are implied by
:ghc-flag:`-W`.
- Added the :ghc-flag:`-Wtoo-many-guards` flag. When enabled, this will issue a
warning if a pattern match contains too many guards (over 20 at the
moment). Makes a difference only if pattern match checking is also enabled.
- Added the :ghc-flag:`-ffull-guard-reasoning` flag. When enabled, pattern match
checking tries its best to reason about guards. Since the additional
expressivity may come with a high price in terms of compilation time and
memory consumption, it is turned off by default.
- :ghc-flag:`-this-package-key` has been renamed again (hopefully for the last time!)
to :ghc-flag:`-this-unit-id`. The renaming was motivated by the fact that
the identifier you pass to GHC here doesn't have much to do with packages:
......
......@@ -358,16 +358,6 @@ Bugs in GHC
This flag ensures that yield points are inserted at every function entrypoint
(at the expense of a bit of performance).
- GHC's updated exhaustiveness and coverage checker (see
:ref:`options-sanity`) is quite expressive but with a rather high
performance cost (in terms of both time and memory consumption), mainly
due to guards. Two flags have been introduced to give more control to
the user over guard reasoning: :ghc-flag:`-Wtoo-many-guards`
and :ghc-flag:`-ffull-guard-reasoning` (see :ref:`options-sanity`).
When :ghc-flag:`-ffull-guard-reasoning` is on, pattern match checking for guards
runs in full power, which may run out of memory/substantially increase
compilation time.
- GHC does not allow you to have a data type with a context that
mentions type variables that are not data type parameters. For
example:
......
......@@ -527,40 +527,6 @@ of ``-W(no-)*``.
This option isn't enabled by default because it can be very noisy,
and it often doesn't indicate a bug in the program.
.. ghc-flag:: -Wtoo-many-guards
-Wno-too-many-guards
.. index::
single: too many guards, warning
The option :ghc-flag:`-Wtoo-many-guards` warns about places where a
pattern match contains too many guards (over 20 at the moment).
It has an effect only if any form of exhaustivness/overlapping
checking is enabled (one of
:ghc-flag:`-Wincomplete-patterns`,
:ghc-flag:`-Wincomplete-uni-patterns`,
:ghc-flag:`-Wincomplete-record-updates`,
:ghc-flag:`-Woverlapping-patterns`). When enabled, the warning can be
suppressed by enabling either :ghc-flag:`-Wno-too-many-guards`, which just
hides the warning, or :ghc-flag:`-ffull-guard-reasoning` which runs the
full check, independently of the number of guards.
.. ghc-flag:: -ffull-guard-reasoning
:implies: :ghc-flag:`-Wno-too-many-guards`
.. index::
single: guard reasoning, warning
The option :ghc-flag:`-ffull-guard-reasoning` forces pattern match checking
to run in full. This gives more precise warnings concerning pattern
guards but in most cases increases memory consumption and
compilation time. Hence, it is off by default. Enabling
:ghc-flag:`-ffull-guard-reasoning` also implies :ghc-flag:`-Wno-too-many-guards`.
Note that (like :ghc-flag:`-Wtoo-many-guards`) :ghc-flag:`-ffull-guard-reasoning`
makes a difference only if pattern match checking is already
enabled.
.. ghc-flag:: -Wmissing-fields
.. index::
......
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude #-}
{-# OPTIONS_GHC -ffull-guard-reasoning #-}
-----------------------------------------------------------------------------
-- |
......
......@@ -430,7 +430,7 @@ test('T783',
# 2014-09-03: 223377364 (Windows) better specialisation, raft of core-to-core optimisations
# 2014-12-22: 235002220 (Windows) not sure why
(wordsize(64), 1134085384, 10)]),
(wordsize(64), 488592288, 10)]),
# prev: 349263216 (amd64/Linux)
# 07/08/2012: 384479856 (amd64/Linux)
# 29/08/2012: 436927840 (amd64/Linux)
......@@ -457,6 +457,8 @@ test('T783',
# (D757: Emit Typeable instances at site of type definition)
# 2015-12-04: 1134085384 (amd64/Linux)
# (D1535: Major overhaul of pattern match checker, #11162)
# 2016-02-03: 488592288 (amd64/Linux)
# (D1795: Another overhaul of pattern match checker, #11374)
extra_hc_opts('-static')
],
compile,[''])
......
{-# OPTIONS_GHC -Woverlapping-patterns -Wincomplete-patterns #-}
module T11195 where
import TyCoRep
import Coercion
import Type hiding( substTyVarBndr, substTy, extendTCvSubst )
import TcType ( exactTyCoVarsOfType )
import CoAxiom
import VarSet
import VarEnv
import Pair
import InstEnv
type NormalCo = Coercion
type NormalNonIdCo = NormalCo -- Extra invariant: not the identity
type SymFlag = Bool
type ReprFlag = Bool
chooseRole :: ReprFlag -> Role -> Role
chooseRole = undefined
wrapRole :: ReprFlag -> Role -> Coercion -> Coercion
wrapRole = undefined
wrapSym :: SymFlag -> Coercion -> Coercion
wrapSym = undefined
optForAllCoBndr :: LiftingContext -> Bool
-> TyVar -> Coercion -> (LiftingContext, TyVar, Coercion)
optForAllCoBndr = undefined
opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo
opt_trans = undefined
opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role
-> Type -> Type -> Coercion
opt_univ = undefined
opt_co3 :: LiftingContext -> SymFlag -> Maybe Role
-> Role -> Coercion -> NormalCo
opt_co3 = undefined
opt_co2 :: LiftingContext -> SymFlag -> Role -> Coercion -> NormalCo
opt_co2 = undefined
compatible_co :: Coercion -> Coercion -> Bool
compatible_co = undefined
etaTyConAppCo_maybe = undefined
etaAppCo_maybe = undefined
etaForAllCo_maybe = undefined
matchAxiom = undefined
checkAxInstCo = undefined
isAxiom_maybe = undefined
isCohLeft_maybe = undefined
isCohRight_maybe = undefined
opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]
opt_transList is = zipWith (opt_trans is)
opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo
opt_trans_rule is in_co1@(NthCo d1 co1) in_co2@(NthCo d2 co2)
| d1 == d2
, co1 `compatible_co` co2 = undefined
opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2)
| d1 == d2
, co1 `compatible_co` co2 = undefined
-- Push transitivity inside instantiation
opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2)
| ty1 `eqCoercion` ty2
, co1 `compatible_co` co2 = undefined
opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1)
in_co2@(UnivCo p2 r2 _tyl2 tyr2)
| Just prov' <- opt_trans_prov p1 p2 = undefined
where
-- if the provenances are different, opt'ing will be very confusing
opt_trans_prov UnsafeCoerceProv UnsafeCoerceProv
= Just UnsafeCoerceProv
opt_trans_prov (PhantomProv kco1) (PhantomProv kco2)
= Just $ PhantomProv $ opt_trans is kco1 kco2
opt_trans_prov (ProofIrrelProv kco1) (ProofIrrelProv kco2)
= Just $ ProofIrrelProv $ opt_trans is kco1 kco2
opt_trans_prov (PluginProv str1) (PluginProv str2)
| str1 == str2 = Just p1
opt_trans_prov _ _ = Nothing
-- Push transitivity down through matching top-level constructors.
opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1)
in_co2@(TyConAppCo r2 tc2 cos2)
| tc1 == tc2 = undefined
opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)
= undefined
-- Eta rules
opt_trans_rule is co1@(TyConAppCo r tc cos1) co2
| Just cos2 <- etaTyConAppCo_maybe tc co2 = undefined
opt_trans_rule is co1 co2@(TyConAppCo r tc cos2)
| Just cos1 <- etaTyConAppCo_maybe tc co1 = undefined
opt_trans_rule is co1@(AppCo co1a co1b) co2
| Just (co2a,co2b) <- etaAppCo_maybe co2 = undefined
opt_trans_rule is co1 co2@(AppCo co2a co2b)
| Just (co1a,co1b) <- etaAppCo_maybe co1 = undefined
-- Push transitivity inside forall