diff options
author | Sebastian Graf <sebastian.graf@kit.edu> | 2020-05-22 17:40:12 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-05-28 16:25:14 -0400 |
commit | 08dab5f74e021ad054112cc5f6bb7e55d8796cd7 (patch) | |
tree | 0fac354ccfa464d95334a85b7eb8b8a41d631563 /testsuite/tests/stranal | |
parent | 10e6982c6117e55b0151dc456e75ebc4798df73f (diff) | |
download | haskell-08dab5f74e021ad054112cc5f6bb7e55d8796cd7.tar.gz |
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.
Diffstat (limited to 'testsuite/tests/stranal')
-rw-r--r-- | testsuite/tests/stranal/sigs/T18086.hs | 23 | ||||
-rw-r--r-- | testsuite/tests/stranal/sigs/T18086.stderr | 21 | ||||
-rw-r--r-- | testsuite/tests/stranal/sigs/all.T | 1 |
3 files changed, 45 insertions, 0 deletions
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']) |