Introduce -fcatch-bottoms

This flag instructs the simplifier to emit ``error`` expressions in the
continutation of empty case analyses (which should bottom and
consequently not return). This is helpful when debugging demand analysis
bugs which can sometimes manifest as segmentation faults.

Test Plan: Validate

Reviewers: simonpj, austin

Subscribers: niteria, rwbarton, thomie

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

5 files changed, 31 insertions, 2 deletions

diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index 5327acddf0..4f7a0da835 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -645,8 +645,21 @@ cpeRhsE env (Case scrut bndr ty alts)
        ; let bndr1 = bndr `setIdUnfolding` evaldUnfolding
             -- Record that the case binder is evaluated in the alternatives
        ; (env', bndr2) <- cpCloneBndr env bndr1
-       ; alts' <- mapM (sat_alt env') alts
-       ; return (floats, Case scrut' bndr2 ty alts') }
+       ; let alts'
+                 -- This flag is intended to aid in debugging strictness
+                 -- analysis bugs. These are particularly nasty to chase down as
+                 -- they may manifest as segmentation faults. When this flag is
+                 -- enabled we instead produce an 'error' expression to catch
+                 -- the case where a function we think should bottom
+                 -- unexpectedly returns.
+               | gopt Opt_CatchBottoms (cpe_dynFlags env)
+               , not (altsAreExhaustive alts)
+               = addDefault alts (Just err)
+               | otherwise = alts
+               where err = mkRuntimeErrorApp rUNTIME_ERROR_ID ty
+                                             "Bottoming expression returned"
+       ; alts'' <- mapM (sat_alt env') alts'
+       ; return (floats, Case scrut' bndr2 ty alts'') }
   where
     sat_alt env (con, bs, rhs)
        = do { (env2, bs') <- cpCloneBndrs env bs
diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index eec524f86d..540a36e0a1 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -30,6 +30,7 @@ module CoreUtils (
         exprIsBig, exprIsConLike,
         rhsIsStatic, isCheapApp, isExpandableApp,
         exprIsLiteralString, exprIsTopLevelBindable,
+        altsAreExhaustive,
 
         -- * Equality
         cheapEqExpr, cheapEqExpr', eqExpr,
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 2be121e133..5e33c2ee54 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -470,6 +470,7 @@ data GeneralFlag
    | Opt_CprAnal
    | Opt_WorkerWrapper
    | Opt_SolveConstantDicts
+   | Opt_CatchBottoms
 
    -- Interface files
    | Opt_IgnoreInterfacePragmas
@@ -3778,6 +3779,7 @@ fFlagsDeps = [
   flagSpec "version-macros"                   Opt_VersionMacros,
   flagSpec "worker-wrapper"                   Opt_WorkerWrapper,
   flagSpec "solve-constant-dicts"             Opt_SolveConstantDicts,
+  flagSpec "catch-bottoms"                    Opt_CatchBottoms,
   flagSpec "show-warning-groups"              Opt_ShowWarnGroups,
   flagSpec "hide-source-paths"                Opt_HideSourcePaths,
   flagSpec "show-hole-constraints"            Opt_ShowHoleConstraints,
diff --git a/docs/users_guide/debugging.rst b/docs/users_guide/debugging.rst
index fd4adc7d20..af937ae64d 100644
--- a/docs/users_guide/debugging.rst
+++ b/docs/users_guide/debugging.rst
@@ -389,6 +389,13 @@ Checking for consistency
     instead of ``undef`` in calls. This makes it easier to catch subtle
     code generator and runtime system bugs (e.g. see :ghc-ticket:`11487`).
 
+.. ghc-flag:: -fcatch-bottoms
+
+    Instructs the simplifier to emit ``error`` expressions in the continuation
+    of empty case analyses (which should bottom and consequently not return).
+    This is helpful when debugging demand analysis bugs which can sometimes
+    manifest as segmentation faults.
+
 .. _checking-determinism:
 
 Checking for determinism
diff --git a/utils/mkUserGuidePart/Options/CompilerDebugging.hs b/utils/mkUserGuidePart/Options/CompilerDebugging.hs
index 9704020601..e68216bdeb 100644
--- a/utils/mkUserGuidePart/Options/CompilerDebugging.hs
+++ b/utils/mkUserGuidePart/Options/CompilerDebugging.hs
@@ -278,4 +278,10 @@ compilerDebuggingOptions =
            "Takes a string argument."
          , flagType = DynamicFlag
          }
+  , flag { flagName = "-fcatch-bottoms"
+         , flagDescription =
+           "Insert ``error`` expressions after bottoming expressions; useful "++
+           "when debugging the compiler."
+         , flagType = DynamicFlag
+         }
   ]