Adding flags: -ffull-guard-reasoning and too-many-guards

Introduction of two new flags, for more precise control over the new
pattern match checker's behaviour when reasoning about guards. This is
supposed to address #11195 (and maybe more performance bugs related to
the NP-Hardness of coverage checking).

Expected behaviour:

  * When `-ffull-guard-reasoning` is on, run the new pattern match
    checker in its full power

  * When `-ffull-guard-reasoning` is off (the default), for every
    match, check a metric to see whether pattern match checking for it
    has high probability of being non performant (at the the moment we
    check whether the number of guards is over 20 but I would like to
    use a more precise measure in the future). If the probability is
    high:

    - Oversimplify the guards (less expressive but more performant)
      and run the checker, and

    - Issue a warning about the simplification that happened.

A new flag `-Wtoo-many-guards/-Wno-too-many-guards` suppresses the
warning about the simplification (useful when combined with -Werror).

Test Plan: validate

Reviewers: goldfire, austin, hvr, bgamari

Reviewed By: bgamari

Subscribers: mpickering, thomie

Differential Revision: https://phabricator.haskell.org/D1676

GHC Trac Issues: #11195

1 files changed, 20 insertions, 6 deletions

diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index 7530a0a243..af07e5b9e4 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -47,7 +47,7 @@ import Name
 import Outputable
 import BasicTypes ( isGenerated )
 
-import Control.Monad( unless )
+import Control.Monad( when, unless )
 import qualified Data.Map as Map
 
 {-
@@ -688,11 +688,25 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
         ; eqns_info   <- mapM (mk_eqn_info new_vars) matches
 
         -- pattern match check warnings
-        ; unless (isGenerated origin) $
-            -- See Note [Type and Term Equality Propagation]
-            addTmCsDs (genCaseTmCs1 mb_scr new_vars) $
-              dsPmWarn dflags (DsMatchContext ctxt locn) $
-                checkMatches new_vars matches
+        ; unless (isGenerated origin) $ 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]
+              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))
 
         ; result_expr <- handleWarnings $
                          matchEquations ctxt new_vars eqns_info rhs_ty