summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/GHC/Core/Op/Simplify/Utils.hs9
-rw-r--r--compiler/GHC/Types/Demand.hs48
-rw-r--r--compiler/prelude/primops.txt.pp21
-rw-r--r--testsuite/tests/stranal/should_run/T17676.hs18
-rw-r--r--testsuite/tests/stranal/should_run/all.T3
5 files changed, 77 insertions, 22 deletions
diff --git a/compiler/GHC/Core/Op/Simplify/Utils.hs b/compiler/GHC/Core/Op/Simplify/Utils.hs
index 1b8c21f81b..17f2a73416 100644
--- a/compiler/GHC/Core/Op/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Op/Simplify/Utils.hs
@@ -56,12 +56,13 @@ import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Var
import GHC.Types.Demand
+import GHC.Types.Var.Set
+import GHC.Types.Basic
+import PrimOp
import GHC.Core.Op.Simplify.Monad
import GHC.Core.Type hiding( substTy )
import GHC.Core.Coercion hiding( substCo )
import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon )
-import GHC.Types.Var.Set
-import GHC.Types.Basic
import Util
import OrdList ( isNilOL )
import MonadUtils
@@ -500,7 +501,9 @@ mkArgInfo env fun rules n_val_args call_cont
-- calls to error. But now we are more careful about
-- inlining lone variables, so it's ok
-- (see GHC.Core.Op.Simplify.Utils.analyseCont)
- if isBotDiv result_info then
+ -- See Note [Precise exceptions and strictness analysis] in Demand.hs
+ -- for the special case on raiseIO#
+ if isBotDiv result_info || isPrimOpId_maybe fun == Just RaiseIOOp then
map isStrictDmd demands -- Finite => result is bottom
else
map isStrictDmd demands ++ vanilla_stricts
diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs
index f9ca821872..fe82d473b2 100644
--- a/compiler/GHC/Types/Demand.hs
+++ b/compiler/GHC/Types/Demand.hs
@@ -931,6 +931,54 @@ instance Outputable Divergence where
ppr Diverges = char 'b'
ppr Dunno = empty
+{- Note [Precise vs imprecise exceptions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+An exception is considered to be /precise/ when it is thrown by the 'raiseIO#'
+primop. It follows that all other primops (such as 'raise#' or
+division-by-zero) throw /imprecise/ exceptions. Note that the actual type of
+the exception thrown doesn't have any impact!
+
+GHC undertakes some effort not to apply an optimisation that would mask a
+/precise/ exception with some other source of nontermination, such as genuine
+divergence or an imprecise exception, so that the user can reliably
+intercept the precise exception with a catch handler before and after
+optimisations.
+
+See also the wiki page on precise exceptions:
+https://gitlab.haskell.org/ghc/ghc/wikis/exceptions/precise-exceptions
+Section 5 of "Tackling the awkward squad" talks about semantic concerns.
+Imprecise exceptions are actually more interesting than precise ones (which are
+fairly standard) from the perspective of semantics. See the paper "A Semantics
+for Imprecise Exceptions" for more details.
+
+Note [Precise exceptions and strictness analysis]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+raiseIO# raises a *precise* exception, in contrast to raise# which
+raise an *imprecise* exception. See Note [Precise vs imprecise exceptions]
+in XXXX.
+
+Unlike raise# (which returns botDiv), we want raiseIO# to return topDiv.
+Here's why. Consider this example from #13380 (similarly #17676):
+ f x y | x>0 = raiseIO Exc
+ | y>0 = return 1
+ | otherwise = return 2
+Is 'f' strict in 'y'? One might be tempted to say yes! But that plays fast and
+loose with the precise exception; after optimisation, (f 42 (error "boom"))
+turns from throwing the precise Exc to throwing the imprecise user error
+"boom". So, the defaultDmd of raiseIO# should be lazy (topDmd), which can be
+achieved by giving it divergence topDiv.
+
+But if it returns topDiv, the simplifier will fail to discard raiseIO#'s
+continuation in
+ case raiseIO# x s of { (# s', r #) -> <BIG> }
+which we'd like to optimise to
+ raiseIO# x s
+Temporary hack solution: special treatment for raiseIO# in
+Simplifier.Utils.mkArgInfo. For the non-hack solution, see
+https://gitlab.haskell.org/ghc/ghc/wikis/fixing-precise-exceptions#replacing-hacks-by-principled-program-analyses
+-}
+
+
------------------------------------------------------------------------
-- Combined demand result --
------------------------------------------------------------------------
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index e5ad02d01b..a29fbf48d7 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -2644,27 +2644,12 @@ primop RaiseOverflowOp "raiseOverflow#" GenPrimOp
out_of_line = True
has_side_effects = True
--- raiseIO# needs to be a primop, because exceptions in the IO monad
--- must be *precise* - we don't want the strictness analyser turning
--- one kind of bottom into another, as it is allowed to do in pure code.
---
--- But we *do* want to know that it returns bottom after
--- being applied to two arguments, so that this function is strict in y
--- f x y | x>0 = raiseIO blah
--- | y>0 = return 1
--- | otherwise = return 2
---
--- TODO Check that the above notes on @f@ are valid. The function successfully
--- produces an IO exception when compiled without optimization. If we analyze
--- it as strict in @y@, won't we change that behavior under optimization?
--- I thought the rule was that it was okay to replace one valid imprecise
--- exception with another, but not to replace a precise exception with
--- an imprecise one (dfeuer, 2017-03-05).
-
primop RaiseIOOp "raiseIO#" GenPrimOp
a -> State# RealWorld -> (# State# RealWorld, b #)
with
- strictness = { \ _arity -> mkClosedStrictSig [topDmd, topDmd] botDiv }
+ -- See Note [Precise exceptions and strictness analysis] in Demand.hs
+ -- for why we give it topDiv
+ -- strictness = { \ _arity -> mkClosedStrictSig [topDmd, topDmd] topDiv }
out_of_line = True
has_side_effects = True
diff --git a/testsuite/tests/stranal/should_run/T17676.hs b/testsuite/tests/stranal/should_run/T17676.hs
new file mode 100644
index 0000000000..d0fa4cf661
--- /dev/null
+++ b/testsuite/tests/stranal/should_run/T17676.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+import Data.IORef
+import Control.Exception
+import Control.Monad
+
+data Exc = Exc deriving Show
+
+instance Exception Exc
+
+-- Recursive instead of NOINLINE because of #17673
+f :: Int -> Int -> IO ()
+f 0 x = do
+ let true = sum [0..4] == 10
+ when true $ throwIO Exc
+ x `seq` return ()
+f n x = f (n-1) (x+1)
+
+main = f 1 (error "expensive computation") `catch` \(_ :: Exc) -> return ()
diff --git a/testsuite/tests/stranal/should_run/all.T b/testsuite/tests/stranal/should_run/all.T
index 278b91b292..d822e482dd 100644
--- a/testsuite/tests/stranal/should_run/all.T
+++ b/testsuite/tests/stranal/should_run/all.T
@@ -19,7 +19,8 @@ test('T11076', normal, multimod_compile_and_run, ['T11076.hs', 'T11076_prim.cmm'
test('T11555a', normal, compile_and_run, [''])
test('T12368', exit_code(1), compile_and_run, [''])
test('T12368a', exit_code(1), compile_and_run, [''])
-test('T13380', [expect_broken(13380), exit_code(1)], compile_and_run, [''])
+test('T13380', exit_code(1), compile_and_run, [''])
test('T14171', [expect_broken(14171), exit_code(1)], compile_and_run, [''])
test('T14290', normal, compile_and_run, [''])
test('T14285', normal, multimod_compile_and_run, ['T14285', ''])
+test('T17676', normal, compile_and_run, [''])