DmdAnal: Recognise precise exceptions from case alternatives (#18086)wip/T18086

Consider

```hs
m :: IO ()
m = do
  putStrLn "foo"
  error "bar"
```

`m` (from #18086) always throws a (precise or imprecise) exception or
diverges. Yet demand analysis infers `<L,A>` as demand signature instead
of `<L,A>x` for it.

That's because the demand analyser sees `putStrLn` occuring in a case
scrutinee and decides that it has to `deferAfterPreciseException`,
because `putStrLn` throws a precise exception on some control flow
paths. This will mask the `botDiv` `Divergence`of the single case alt
containing `error` to `topDiv`. Since `putStrLn` has `topDiv` itself,
the final `Divergence` is `topDiv`.

This is easily fixed: `deferAfterPreciseException` works by `lub`ing
with the demand type of a virtual case branch denoting the precise
exceptional control flow. We used `nopDmdType` before, but we can be
more precise and use `exnDmdType`, which is `nopDmdType` with `exnDiv`.

Now the `Divergence` from the case alt will degrade `botDiv` to `exnDiv`
instead of `topDiv`, which combines with the result from the scrutinee
to `exnDiv`, and all is well.

Fixes #18086.

4 files changed, 70 insertions, 8 deletions

diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs
index 416eff9f4a..cbbbe6688d 100644
--- a/compiler/GHC/Types/Demand.hs
+++ b/compiler/GHC/Types/Demand.hs
@@ -1055,11 +1055,19 @@ Is this strict in 'y'? Often not! If @foo x s@ might throw a precise exception
 (ultimately via raiseIO#), then we must not force 'y', which may fail to
 terminate or throw an imprecise exception, until we have performed @foo x s@.
 
-So we have to 'Demand.deferAfterPreciseException' (which just 'lub's with
-'nopDmdType' to model the exceptional control flow) when @foo x s@
-may throw a precise exception. Motivated by T13380{d,e,f}.
+So we have to 'deferAfterPreciseException' (which 'lub's with 'exnDmdType' to
+model the exceptional control flow) when @foo x s@ may throw a precise
+exception. Motivated by T13380{d,e,f}.
 See Note [Which scrutinees may throw precise exceptions] in DmdAnal.
 
+We have to be careful not to discard dead-end Divergence from case
+alternatives, though (#18086):
+
+  m = putStrLn "foo" >> error "bar"
+
+'m' should still have 'exnDiv', which is why it is not sufficient to lub with
+'nopDmdType' (which has 'topDiv') in 'deferAfterPreciseException'.
+
 Historical Note: This used to be called the "IO hack". But that term is rather
 a bad fit because
 1. It's easily confused with the "State hack", which also affects IO.
@@ -1261,6 +1269,11 @@ isTopDmdType :: DmdType -> Bool
 isTopDmdType (DmdType env args div)
   = div == topDiv && null args && isEmptyVarEnv env
 
+-- | The demand type of an unspecified expression that is guaranteed to
+-- throw a (precise or imprecise) exception or diverge.
+exnDmdType :: DmdType
+exnDmdType = DmdType emptyDmdEnv [] exnDiv
+
 dmdTypeDepth :: DmdType -> Arity
 dmdTypeDepth (DmdType _ ds _) = length ds
 
@@ -1303,13 +1316,17 @@ splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)
 splitDmdTy ty@(DmdType _ [] res_ty)       = (defaultArgDmd res_ty, ty)
 
 -- | When e is evaluated after executing an IO action that may throw a precise
--- exception, and d is e's demand, then what of this demand should we consider?
--- * We have to kill all strictness demands (i.e. lub with a lazy demand)
--- * We can keep usage information (i.e. lub with an absent demand)
--- * We have to kill definite divergence
+-- exception, we act as if there is an additional control flow path that is
+-- taken if e throws a precise exception. The demand type of this control flow
+-- path
+--   * is lazy and absent ('topDmd') in all free variables and arguments
+--   * has 'exnDiv' 'Divergence' result
+-- So we can simply take a variant of 'nopDmdType', 'exnDmdType'.
+-- Why not 'nopDmdType'? Because then the result of 'e' can never be 'exnDiv'!
+-- That means failure to drop dead-ends, see #18086.
 -- See Note [Precise exceptions and strictness analysis]
 deferAfterPreciseException :: DmdType -> DmdType
-deferAfterPreciseException d = lubDmdType d nopDmdType
+deferAfterPreciseException = lubDmdType exnDmdType
 
 strictenDmd :: Demand -> CleanDemand
 strictenDmd (JD { sd = s, ud = u})
diff --git a/testsuite/tests/stranal/sigs/T18086.hs b/testsuite/tests/stranal/sigs/T18086.hs
new file mode 100644
index 0000000000..639409adce
--- /dev/null
+++ b/testsuite/tests/stranal/sigs/T18086.hs
@@ -0,0 +1,23 @@
+{-# OPTIONS_GHC -O2 -fforce-recomp #-}
+module T18086 where
+
+import GHC.Stack
+import GHC.Utils.Panic.Plain
+import Control.Exception
+import System.IO.Unsafe
+
+-- Should have strictness signature <L,U>x, emphasis on the exceptional
+-- divergence result.
+m :: IO ()
+m = do
+  putStrLn "foo"
+  error "bar"
+
+-- Dito, just in a more complex scenario (the original reproducer of #18086)
+panic :: String -> a
+panic x = unsafeDupablePerformIO $ do
+  stack <- ccsToStrings =<< getCurrentCCS x
+  if null stack
+  then throw (PlainPanic x)
+  else throw (PlainPanic (x ++ '\n' : renderStack stack))
+
diff --git a/testsuite/tests/stranal/sigs/T18086.stderr b/testsuite/tests/stranal/sigs/T18086.stderr
new file mode 100644
index 0000000000..6941e233f8
--- /dev/null
+++ b/testsuite/tests/stranal/sigs/T18086.stderr
@@ -0,0 +1,21 @@
+
+==================== Strictness signatures ====================
+T18086.$trModule:
+T18086.m: <L,U>x
+T18086.panic: <L,U>x
+
+
+
+==================== Cpr signatures ====================
+T18086.$trModule:
+T18086.m: b
+T18086.panic:
+
+
+
+==================== Strictness signatures ====================
+T18086.$trModule:
+T18086.m: <L,U>x
+T18086.panic: <L,U>x
+
+
diff --git a/testsuite/tests/stranal/sigs/all.T b/testsuite/tests/stranal/sigs/all.T
index 8802389cb4..387a1a7f7d 100644
--- a/testsuite/tests/stranal/sigs/all.T
+++ b/testsuite/tests/stranal/sigs/all.T
@@ -22,3 +22,4 @@ test('T5075', normal, compile, [''])
 test('T17932', normal, compile, [''])
 test('T13380c', expect_broken('!3014'), compile, [''])
 test('T13380f', normal, compile, [''])
+test('T18086', normal, compile, ['-package ghc'])