From 08dab5f74e021ad054112cc5f6bb7e55d8796cd7 Mon Sep 17 00:00:00 2001
From: Sebastian Graf <sebastian.graf@kit.edu>
Date: Fri, 22 May 2020 17:40:12 +0200
Subject: DmdAnal: Recognise precise exceptions from case alternatives (#18086)

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.
---
 testsuite/tests/stranal/sigs/T18086.hs     | 23 +++++++++++++++++++++++
 testsuite/tests/stranal/sigs/T18086.stderr | 21 +++++++++++++++++++++
 testsuite/tests/stranal/sigs/all.T         |  1 +
 3 files changed, 45 insertions(+)
 create mode 100644 testsuite/tests/stranal/sigs/T18086.hs
 create mode 100644 testsuite/tests/stranal/sigs/T18086.stderr

(limited to 'testsuite/tests/stranal')

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'])
-- 
cgit v1.2.1