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 ( ...@@ -34,6 +34,9 @@ module DsMonad (
-- Getting and setting EvVars and term constraints in local environment -- Getting and setting EvVars and term constraints in local environment
getDictsDs, addDictsDs, getTmCsDs, addTmCsDs, getDictsDs, addDictsDs, getTmCsDs, addTmCsDs,
-- Iterations for pm checking
incrCheckPmIterDs, resetPmIterDs,
-- Warnings -- Warnings
DsWarning, warnDs, failWithDs, discardWarningsDs, DsWarning, warnDs, failWithDs, discardWarningsDs,
...@@ -146,10 +149,12 @@ initDs :: HscEnv ...@@ -146,10 +149,12 @@ initDs :: HscEnv
initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside
= do { msg_var <- newIORef (emptyBag, emptyBag) = do { msg_var <- newIORef (emptyBag, emptyBag)
; static_binds_var <- newIORef [] ; static_binds_var <- newIORef []
; pm_iter_var <- newIORef 0
; let dflags = hsc_dflags hsc_env ; let dflags = hsc_dflags hsc_env
(ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env
fam_inst_env msg_var fam_inst_env msg_var
static_binds_var static_binds_var
pm_iter_var
; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $ ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
loadDAP $ loadDAP $
...@@ -225,11 +230,12 @@ initDsTc thing_inside ...@@ -225,11 +230,12 @@ initDsTc thing_inside
; msg_var <- getErrsVar ; msg_var <- getErrsVar
; dflags <- getDynFlags ; dflags <- getDynFlags
; static_binds_var <- liftIO $ newIORef [] ; static_binds_var <- liftIO $ newIORef []
; pm_iter_var <- liftIO $ newIORef 0
; let type_env = tcg_type_env tcg_env ; let type_env = tcg_type_env tcg_env
rdr_env = tcg_rdr_env tcg_env rdr_env = tcg_rdr_env tcg_env
fam_inst_env = tcg_fam_inst_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 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 ; setEnvs ds_envs thing_inside
} }
...@@ -258,8 +264,8 @@ initTcDsForSolver thing_inside ...@@ -258,8 +264,8 @@ initTcDsForSolver thing_inside
mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> IORef Messages -> IORef [(Fingerprint, (Id, CoreExpr))] -> IORef Messages -> IORef [(Fingerprint, (Id, CoreExpr))]
-> (DsGblEnv, DsLclEnv) -> IORef Int -> (DsGblEnv, DsLclEnv)
mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var static_binds_var 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) } = 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) if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1) 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 ...@@ -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_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"
, ds_static_binds = static_binds_var , ds_static_binds = static_binds_var
} }
lcl_env = DsLclEnv { dsl_meta = emptyNameEnv lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
, dsl_loc = real_span , dsl_loc = real_span
, dsl_dicts = emptyBag , dsl_dicts = emptyBag
, dsl_tm_cs = emptyBag , dsl_tm_cs = emptyBag
, dsl_pm_iter = pmvar
} }
in (gbl_env, lcl_env) in (gbl_env, lcl_env)
...@@ -355,6 +362,24 @@ addTmCsDs :: Bag SimpleEq -> DsM a -> DsM a ...@@ -355,6 +362,24 @@ addTmCsDs :: Bag SimpleEq -> DsM a -> DsM a
addTmCsDs tm_cs addTmCsDs tm_cs
= updLclEnv (\env -> env { dsl_tm_cs = unionBags tm_cs (dsl_tm_cs env) }) = 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 :: DsM SrcSpan
getSrcSpanDs = do { env <- getLclEnv getSrcSpanDs = do { env <- getLclEnv
; return (RealSrcSpan (dsl_loc env)) } ; return (RealSrcSpan (dsl_loc env)) }
......
...@@ -694,21 +694,9 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches ...@@ -694,21 +694,9 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
when (isAnyPmCheckEnabled dflags (DsMatchContext ctxt locn)) $ do 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] -- See Note [Type and Term Equality Propagation]
addTmCsDs (genCaseTmCs1 mb_scr new_vars) $ addTmCsDs (genCaseTmCs1 mb_scr new_vars) $
dsPmWarn dflags (DsMatchContext ctxt locn) $ checkMatches dflags (DsMatchContext ctxt locn) new_vars matches
checkMatches simplify new_vars matches
when (not (gopt Opt_FullGuardReasoning dflags)
&& wopt Opt_WarnTooManyGuards dflags
&& guards > maximum_failing_guards)
(warnManyGuards (DsMatchContext ctxt locn))
; result_expr <- handleWarnings $ ; result_expr <- handleWarnings $
matchEquations ctxt new_vars eqns_info rhs_ty matchEquations ctxt new_vars eqns_info rhs_ty
...@@ -777,7 +765,7 @@ matchSinglePat (Var var) ctx pat ty match_result ...@@ -777,7 +765,7 @@ matchSinglePat (Var var) ctx pat ty match_result
; locn <- getSrcSpanDs ; locn <- getSrcSpanDs
; let pat' = getMaybeStrictPat dflags pat ; let pat' = getMaybeStrictPat dflags pat
-- pattern match check warnings -- pattern match check warnings
; dsPmWarn dflags (DsMatchContext ctx locn) (checkSingle var pat') ; checkSingle dflags (DsMatchContext ctx locn) var pat'
; match [var] ty ; match [var] ty
[EqnInfo { eqn_pats = [pat'], eqn_rhs = match_result }] } [EqnInfo { eqn_pats = [pat'], eqn_rhs = match_result }] }
......
...@@ -7,7 +7,7 @@ Haskell expressions (as used by the pattern matching checker) and utilities. ...@@ -7,7 +7,7 @@ Haskell expressions (as used by the pattern matching checker) and utilities.
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module PmExpr ( module PmExpr (
PmExpr(..), PmLit(..), SimpleEq, ComplexEq, eqPmLit, PmExpr(..), PmLit(..), SimpleEq, ComplexEq, toComplex, eqPmLit,
truePmExpr, falsePmExpr, isTruePmExpr, isFalsePmExpr, isNotPmExprOther, truePmExpr, falsePmExpr, isTruePmExpr, isFalsePmExpr, isNotPmExprOther,
lhsExprToPmExpr, hsExprToPmExpr, substComplexEq, filterComplex, lhsExprToPmExpr, hsExprToPmExpr, substComplexEq, filterComplex,
pprPmExprWithParens, runPmPprM pprPmExprWithParens, runPmPprM
...@@ -17,12 +17,13 @@ module PmExpr ( ...@@ -17,12 +17,13 @@ module PmExpr (
import HsSyn import HsSyn
import Id import Id
import Name
import NameSet
import DataCon import DataCon
import TysWiredIn import TysWiredIn
import Outputable import Outputable
import Util import Util
import SrcLoc import SrcLoc
import VarSet
import Data.Maybe (mapMaybe) import Data.Maybe (mapMaybe)
import Data.List (groupBy, sortBy, nubBy) import Data.List (groupBy, sortBy, nubBy)
...@@ -50,7 +51,7 @@ refer to variables that are otherwise substituted away. ...@@ -50,7 +51,7 @@ refer to variables that are otherwise substituted away.
-- ** Types -- ** Types
-- | Lifted expressions for pattern match checking. -- | Lifted expressions for pattern match checking.
data PmExpr = PmExprVar Id data PmExpr = PmExprVar Name
| PmExprCon DataCon [PmExpr] | PmExprCon DataCon [PmExpr]
| PmExprLit PmLit | PmExprLit PmLit
| PmExprEq PmExpr PmExpr -- Syntactic equality | PmExprEq PmExpr PmExpr -- Syntactic equality
...@@ -140,6 +141,10 @@ nubPmLit = nubBy eqPmLit ...@@ -140,6 +141,10 @@ nubPmLit = nubBy eqPmLit
type SimpleEq = (Id, PmExpr) -- We always use this orientation type SimpleEq = (Id, PmExpr) -- We always use this orientation
type ComplexEq = (PmExpr, PmExpr) type ComplexEq = (PmExpr, PmExpr)
-- | Lift a `SimpleEq` to a `ComplexEq`
toComplex :: SimpleEq -> ComplexEq
toComplex (x,e) = (PmExprVar (idName x), e)
-- | Expression `True' -- | Expression `True'
truePmExpr :: PmExpr truePmExpr :: PmExpr
truePmExpr = PmExprCon trueDataCon [] truePmExpr = PmExprCon trueDataCon []
...@@ -193,7 +198,7 @@ isConsDataCon con = consDataCon == con ...@@ -193,7 +198,7 @@ isConsDataCon con = consDataCon == con
-- | We return a boolean along with the expression. Hence, if substitution was -- | We return a boolean along with the expression. Hence, if substitution was
-- a no-op, we know that the expression still cannot progress. -- 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 = substPmExpr x e1 e =
case e of case e of
PmExprVar z | x == z -> (e1, True) PmExprVar z | x == z -> (e1, True)
...@@ -208,7 +213,7 @@ substPmExpr x e1 e = ...@@ -208,7 +213,7 @@ substPmExpr x e1 e =
-- | Substitute in a complex equality. We return (Left eq) if the substitution -- | Substitute in a complex equality. We return (Left eq) if the substitution
-- affected the equality or (Right eq) if nothing happened. -- 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) substComplexEq x e (ex, ey)
| bx || by = Left (ex', ey') | bx || by = Left (ex', ey')
| otherwise = Right (ex', ey') | otherwise = Right (ex', ey')
...@@ -224,7 +229,7 @@ lhsExprToPmExpr (L _ e) = hsExprToPmExpr e ...@@ -224,7 +229,7 @@ lhsExprToPmExpr (L _ e) = hsExprToPmExpr e
hsExprToPmExpr :: HsExpr Id -> PmExpr 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 (HsOverLit olit) = PmExprLit (PmOLit False olit)
hsExprToPmExpr (HsLit lit) = PmExprLit (PmSLit lit) hsExprToPmExpr (HsLit lit) = PmExprLit (PmSLit lit)
...@@ -312,7 +317,7 @@ Check.hs) to be more precice. ...@@ -312,7 +317,7 @@ Check.hs) to be more precice.
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- ** Transform residual constraints in appropriate form for pretty printing -- ** Transform residual constraints in appropriate form for pretty printing
type PmNegLitCt = (Id, (SDoc, [PmLit])) type PmNegLitCt = (Name, (SDoc, [PmLit]))
filterComplex :: [ComplexEq] -> [PmNegLitCt] filterComplex :: [ComplexEq] -> [PmNegLitCt]
filterComplex = zipWith rename nameList . map mkGroup filterComplex = zipWith rename nameList . map mkGroup
...@@ -342,19 +347,19 @@ filterComplex = zipWith rename nameList . map mkGroup ...@@ -342,19 +347,19 @@ filterComplex = zipWith rename nameList . map mkGroup
runPmPprM :: PmPprM a -> [PmNegLitCt] -> (a, [(SDoc,[PmLit])]) runPmPprM :: PmPprM a -> [PmNegLitCt] -> (a, [(SDoc,[PmLit])])
runPmPprM m lit_env = (result, mapMaybe is_used lit_env) runPmPprM m lit_env = (result, mapMaybe is_used lit_env)
where where
(result, (_lit_env, used)) = runState m (lit_env, emptyVarSet) (result, (_lit_env, used)) = runState m (lit_env, emptyNameSet)
is_used (x,(name, lits)) is_used (x,(name, lits))
| elemVarSet x used = Just (name, lits) | elemNameSet x used = Just (name, lits)
| otherwise = Nothing | 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?) -- (the first part of the state is read only. make it a reader?)
addUsed :: Id -> PmPprM () addUsed :: Name -> PmPprM ()
addUsed x = modify (\(negated, used) -> (negated, extendVarSet used x)) 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 checkNegation x = do
negated <- gets fst negated <- gets fst
return $ case lookup x negated of return $ case lookup x negated of
......
...@@ -10,14 +10,14 @@ module TmOracle ( ...@@ -10,14 +10,14 @@ module TmOracle (
-- re-exported from PmExpr -- re-exported from PmExpr
PmExpr(..), PmLit(..), SimpleEq, ComplexEq, PmVarEnv, falsePmExpr, PmExpr(..), PmLit(..), SimpleEq, ComplexEq, PmVarEnv, falsePmExpr,
canDiverge, eqPmLit, filterComplex, isNotPmExprOther, runPmPprM, eqPmLit, filterComplex, isNotPmExprOther, runPmPprM, lhsExprToPmExpr,
pprPmExprWithParens, lhsExprToPmExpr, hsExprToPmExpr, hsExprToPmExpr, pprPmExprWithParens,
-- the term oracle -- the term oracle
tmOracle, TmState, initialTmState, tmOracle, TmState, initialTmState, solveOneEq, extendSubst, canDiverge,
-- misc. -- misc.
exprDeepLookup, pmLitType, flattenPmVarEnv toComplex, exprDeepLookup, pmLitType, flattenPmVarEnv
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -25,6 +25,7 @@ module TmOracle ( ...@@ -25,6 +25,7 @@ module TmOracle (
import PmExpr import PmExpr
import Id import Id
import Name
import TysWiredIn import TysWiredIn
import Type import Type
import HsLit import HsLit
...@@ -43,7 +44,7 @@ import qualified Data.Map as Map ...@@ -43,7 +44,7 @@ import qualified Data.Map as Map
-} -}
-- | The type of substitutions. -- | The type of substitutions.
type PmVarEnv = Map.Map Id PmExpr type PmVarEnv = Map.Map Name PmExpr
-- | The environment of the oracle contains -- | The environment of the oracle contains
-- 1. A Bool (are there any constraints we cannot handle? (PmExprOther)). -- 1. A Bool (are there any constraints we cannot handle? (PmExprOther)).
...@@ -52,7 +53,7 @@ type TmOracleEnv = (Bool, PmVarEnv) ...@@ -52,7 +53,7 @@ type TmOracleEnv = (Bool, PmVarEnv)
-- | Check whether a constraint (x ~ BOT) can succeed, -- | Check whether a constraint (x ~ BOT) can succeed,
-- given the resulting state of the term oracle. -- given the resulting state of the term oracle.
canDiverge :: Id -> TmState -> Bool canDiverge :: Name -> TmState -> Bool
canDiverge x (standby, (_unhandled, env)) canDiverge x (standby, (_unhandled, env))
-- If the variable seems not evaluated, there is a possibility for -- If the variable seems not evaluated, there is a possibility for
-- constraint x ~ BOT to be satisfiable. -- constraint x ~ BOT to be satisfiable.
...@@ -66,11 +67,11 @@ canDiverge x (standby, (_unhandled, env)) ...@@ -66,11 +67,11 @@ canDiverge x (standby, (_unhandled, env))
| otherwise = False | otherwise = False
where where
isForcedByEq :: Id -> ComplexEq -> Bool isForcedByEq :: Name -> ComplexEq -> Bool
isForcedByEq y (e1, e2) = varIn y e1 || varIn y e2 isForcedByEq y (e1, e2) = varIn y e1 || varIn y e2
-- | Check whether a variable is in the free variables of an expression -- | 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 varIn x e = case e of
PmExprVar y -> x == y PmExprVar y -> x == y
PmExprCon _ es -> any (x `varIn`) es PmExprCon _ es -> any (x `varIn`) es
...@@ -131,7 +132,7 @@ solveComplexEq solver_state@(standby, (unhandled, env)) eq@(e1, e2) = case eq of ...@@ -131,7 +132,7 @@ solveComplexEq solver_state@(standby, (unhandled, env)) eq@(e1, e2) = case eq of
_ -> Just (standby, (True, env)) -- I HATE CATCH-ALLS _ -> Just (standby, (True, env)) -- I HATE CATCH-ALLS
-- | Extend the substitution and solve the (possibly updated) constraints. -- | 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)) extendSubstAndSolve x e (standby, (unhandled, env))
= foldlM solveComplexEq new_incr_state (map simplifyComplexEq changed) = foldlM solveComplexEq new_incr_state (map simplifyComplexEq changed)
where where
...@@ -142,6 +143,19 @@ extendSubstAndSolve x e (standby, (unhandled, env)) ...@@ -142,6 +143,19 @@ extendSubstAndSolve x e (standby, (unhandled, env))
(changed, unchanged) = partitionWith (substComplexEq x e) standby (changed, unchanged) = partitionWith (substComplexEq x e) standby
new_incr_state = (unchanged, (unhandled, Map.insert x e env)) 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. -- | Simplify a complex equality.
simplifyComplexEq :: ComplexEq -> ComplexEq simplifyComplexEq :: ComplexEq -> ComplexEq
simplifyComplexEq (e1, e2) = (fst $ simplifyPmExpr e1, fst $ simplifyPmExpr e2) simplifyComplexEq (e1, e2) = (fst $ simplifyPmExpr e1, fst $ simplifyPmExpr e2)
...@@ -204,7 +218,7 @@ applySubstComplexEq :: PmVarEnv -> ComplexEq -> ComplexEq ...@@ -204,7 +218,7 @@ applySubstComplexEq :: PmVarEnv -> ComplexEq -> ComplexEq
applySubstComplexEq env (e1,e2) = (exprDeepLookup env e1, exprDeepLookup env e2) applySubstComplexEq env (e1,e2) = (exprDeepLookup env e1, exprDeepLookup env e2)
-- | Apply an (un-flattened) substitution to a variable. -- | Apply an (un-flattened) substitution to a variable.
varDeepLookup :: PmVarEnv -> Id -> PmExpr varDeepLookup :: PmVarEnv -> Name -> PmExpr
varDeepLookup env x varDeepLookup env x
| Just e <- Map.lookup x env = exprDeepLookup env e -- go deeper | Just e <- Map.lookup x env = exprDeepLookup env e -- go deeper
| otherwise = PmExprVar x -- terminal | otherwise = PmExprVar x -- terminal
......
{-# LANGUAGE CPP, ScopedTypeVariables, MagicHash, UnboxedTuples #-} {-# LANGUAGE CPP, ScopedTypeVariables, MagicHash, UnboxedTuples #-}
#if __GLASGOW_HASKELL__ > 710
{-# OPTIONS_GHC -ffull-guard-reasoning #-}
#endif
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- --
......
...@@ -531,9 +531,6 @@ data GeneralFlag ...@@ -531,9 +531,6 @@ data GeneralFlag
-- safe haskell flags -- safe haskell flags
| Opt_DistrustAllPackages | Opt_DistrustAllPackages
| Opt_PackageTrust | Opt_PackageTrust
-- pm checking with guards
| Opt_FullGuardReasoning
deriving (Eq, Show, Enum) deriving (Eq, Show, Enum)
data WarningFlag = data WarningFlag =
...@@ -555,7 +552,6 @@ data WarningFlag = ...@@ -555,7 +552,6 @@ data WarningFlag =
| Opt_WarnMissingLocalSigs | Opt_WarnMissingLocalSigs
| Opt_WarnNameShadowing | Opt_WarnNameShadowing
| Opt_WarnOverlappingPatterns | Opt_WarnOverlappingPatterns
| Opt_WarnTooManyGuards
| Opt_WarnTypeDefaults | Opt_WarnTypeDefaults
| Opt_WarnMonomorphism | Opt_WarnMonomorphism
| Opt_WarnUnusedTopBinds | Opt_WarnUnusedTopBinds
...@@ -645,6 +641,7 @@ data DynFlags = DynFlags { ...@@ -645,6 +641,7 @@ data DynFlags = DynFlags {
debugLevel :: Int, -- ^ How much debug information to produce debugLevel :: Int, -- ^ How much debug information to produce
simplPhases :: Int, -- ^ Number of simplifier phases simplPhases :: Int, -- ^ Number of simplifier phases
maxSimplIterations :: Int, -- ^ Max simplifier iterations maxSimplIterations :: Int, -- ^ Max simplifier iterations
maxPmCheckIterations :: Int, -- ^ Max no iterations for pm checking
ruleCheck :: Maybe String, ruleCheck :: Maybe String,
strictnessBefore :: [Int], -- ^ Additional demand analysis strictnessBefore :: [Int], -- ^ Additional demand analysis
...@@ -1438,6 +1435,7 @@ defaultDynFlags mySettings = ...@@ -1438,6 +1435,7 @@ defaultDynFlags mySettings =
debugLevel = 0, debugLevel = 0,
simplPhases = 2, simplPhases = 2,
maxSimplIterations = 4, maxSimplIterations = 4,
maxPmCheckIterations = 10000000,
ruleCheck = Nothing, ruleCheck = Nothing,
maxRelevantBinds = Just 6, maxRelevantBinds = Just 6,
simplTickFactor = 100, simplTickFactor = 100,
...@@ -2632,6 +2630,8 @@ dynamic_flags = [ ...@@ -2632,6 +2630,8 @@ dynamic_flags = [
(intSuffix (\n d -> d{ simplPhases = n })) (intSuffix (\n d -> d{ simplPhases = n }))
, defFlag "fmax-simplifier-iterations" , defFlag "fmax-simplifier-iterations"
(intSuffix (\n d -> d{ maxSimplIterations = n })) (intSuffix (\n d -> d{ maxSimplIterations = n }))
, defFlag "fmax-pmcheck-iterations"
(intSuffix (\n d -> d{ maxPmCheckIterations = n }))
, defFlag "fsimpl-tick-factor" , defFlag "fsimpl-tick-factor"
(intSuffix (\n d -> d{ simplTickFactor = n })) (intSuffix (\n d -> d{ simplTickFactor = n }))
, defFlag "fspec-constr-threshold" , defFlag "fspec-constr-threshold"
...@@ -2980,7 +2980,6 @@ wWarningFlags = [ ...@@ -2980,7 +2980,6 @@ wWarningFlags = [
flagSpec "orphans" Opt_WarnOrphans, flagSpec "orphans" Opt_WarnOrphans,
flagSpec "overflowed-literals" Opt_WarnOverflowedLiterals, flagSpec "overflowed-literals" Opt_WarnOverflowedLiterals,
flagSpec "overlapping-patterns" Opt_WarnOverlappingPatterns, flagSpec "overlapping-patterns" Opt_WarnOverlappingPatterns,
flagSpec "too-many-guards" Opt_WarnTooManyGuards,
flagSpec "missed-specialisations" Opt_WarnMissedSpecs, flagSpec "missed-specialisations" Opt_WarnMissedSpecs,
flagSpec "all-missed-specialisations" Opt_WarnAllMissedSpecs, flagSpec "all-missed-specialisations" Opt_WarnAllMissedSpecs,
flagSpec' "safe" Opt_WarnSafe setWarnSafe, flagSpec' "safe" Opt_WarnSafe setWarnSafe,
...@@ -3117,8 +3116,7 @@ fFlags = [ ...@@ -3117,8 +3116,7 @@ fFlags = [
flagSpec "unbox-strict-fields" Opt_UnboxStrictFields, flagSpec "unbox-strict-fields" Opt_UnboxStrictFields,
flagSpec "vectorisation-avoidance" Opt_VectorisationAvoidance, flagSpec "vectorisation-avoidance" Opt_VectorisationAvoidance,
flagSpec "vectorise" Opt_Vectorise, flagSpec "vectorise" Opt_Vectorise,
flagSpec "worker-wrapper" Opt_WorkerWrapper, flagSpec "worker-wrapper" Opt_WorkerWrapper
flagSpec "full-guard-reasoning" Opt_FullGuardReasoning
] ]
-- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@
......
-- | Constants describing the DWARF format. Most of this simply -- | Constants describing the DWARF format. Most of this simply
-- mirrors /usr/include/dwarf.h. -- mirrors /usr/include/dwarf.h.
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ > 710
{-# OPTIONS_GHC -ffull-guard-reasoning #-}
#endif
module Dwarf.Constants where module Dwarf.Constants where
......
...@@ -338,7 +338,8 @@ data DsLclEnv = DsLclEnv { ...@@ -338,7 +338,8 @@ data DsLclEnv = DsLclEnv {
dsl_meta :: DsMetaEnv, -- Template Haskell bindings dsl_meta :: DsMetaEnv, -- Template Haskell bindings
dsl_loc :: RealSrcSpan, -- To put in pattern-matching error msgs dsl_loc :: RealSrcSpan, -- To put in pattern-matching error msgs
dsl_dicts :: Bag EvVar, -- Constraints from GADT pattern-matching 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 -- Inside [| |] brackets, the desugarer looks
......
...@@ -2,9 +2,7 @@ ...@@ -2,9 +2,7 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
-- This module used to take 10GB of memory to compile with the new -- 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, -- (Nov '15) pattern-match checker.
-- do not enable -ffull-guard-reasoning. Instead, simplify the guards
-- (default behaviour when guards are too many).
module OptCoercion ( optCoercion, checkAxInstCo ) where module OptCoercion ( optCoercion, checkAxInstCo ) where
......
...@@ -287,15 +287,6 @@ Compiler ...@@ -287,15 +287,6 @@ Compiler
warns in the case of unused term-level patterns. Both flags are implied by warns in the case of unused term-level patterns. Both flags are implied by
:ghc-flag:`-W`. :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!) - :ghc-flag:`-this-package-key` has been renamed again (hopefully for the last time!)