Change catch# demand signature

* Give `catch#` a lazy demand signature, to make it more honest.

* Make `catchException` and `catchAny` force their arguments so they
actually behave as advertised.

* Use `catch` rather than `catchException` in `forkIO`, `forkOn`, and
`forkOS` to avoid losing exceptions.

Fixes #13330

Reviewers: rwbarton, simonpj, simonmar, bgamari, hvr, austin

Subscribers: thomie

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

10 files changed, 102 insertions, 70 deletions

diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs
index 71a044f51f..eab01d0605 100644
--- a/compiler/basicTypes/Demand.hs
+++ b/compiler/basicTypes/Demand.hs
@@ -708,7 +708,7 @@ lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd, catchArgDmd :: Demand
 strictApply1Dmd = JD { sd = Str VanStr (SCall HeadStr)
                      , ud = Use Many (UCall One Used) }
 
--- First argument of catch#:
+-- First argument of catchRetry# and catchSTM#:
 --    uses its arg once, applies it once
 --    and catches exceptions (the ExnStr) part
 catchArgDmd = JD { sd = Str ExnStr (SCall HeadStr)
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index f1ee3b36b0..855bdfcb62 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -1965,7 +1965,7 @@ primop  CatchOp "catch#" GenPrimOp
        -> State# RealWorld
        -> (# State# RealWorld, a #)
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [ catchArgDmd
+   strictness  = { \ _arity -> mkClosedStrictSig [ lazyApply1Dmd
                                                  , lazyApply2Dmd
                                                  , topDmd] topRes }
                  -- See Note [Strictness for mask/unmask/catch]
diff --git a/libraries/base/Control/Concurrent.hs b/libraries/base/Control/Concurrent.hs
index 9b328b6fe8..ada825d0f0 100644
--- a/libraries/base/Control/Concurrent.hs
+++ b/libraries/base/Control/Concurrent.hs
@@ -308,7 +308,7 @@ forkOS action0
                         MaskedInterruptible -> action0
                         MaskedUninterruptible -> uninterruptibleMask_ action0
 
-            action_plus = catchException action1 childHandler
+            action_plus = catch action1 childHandler
 
         entry <- newStablePtr (myThreadId >>= putMVar mv >> action_plus)
         err <- forkOS_createThread entry
diff --git a/libraries/base/Control/Exception/Base.hs b/libraries/base/Control/Exception/Base.hs
index 3e7ac0f9e8..a15cc8ed32 100644
--- a/libraries/base/Control/Exception/Base.hs
+++ b/libraries/base/Control/Exception/Base.hs
@@ -111,45 +111,6 @@ import Data.Either
 -----------------------------------------------------------------------------
 -- Catching exceptions
 
--- |This is the simplest of the exception-catching functions.  It
--- takes a single argument, runs it, and if an exception is raised
--- the \"handler\" is executed, with the value of the exception passed as an
--- argument.  Otherwise, the result is returned as normal.  For example:
---
--- >   catch (readFile f)
--- >         (\e -> do let err = show (e :: IOException)
--- >                   hPutStr stderr ("Warning: Couldn't open " ++ f ++ ": " ++ err)
--- >                   return "")
---
--- Note that we have to give a type signature to @e@, or the program
--- will not typecheck as the type is ambiguous. While it is possible
--- to catch exceptions of any type, see the section \"Catching all
--- exceptions\" (in "Control.Exception") for an explanation of the problems with doing so.
---
--- For catching exceptions in pure (non-'IO') expressions, see the
--- function 'evaluate'.
---
--- Note that due to Haskell\'s unspecified evaluation order, an
--- expression may throw one of several possible exceptions: consider
--- the expression @(error \"urk\") + (1 \`div\` 0)@.  Does
--- the expression throw
--- @ErrorCall \"urk\"@, or @DivideByZero@?
---
--- The answer is \"it might throw either\"; the choice is
--- non-deterministic. If you are catching any type of exception then you
--- might catch either. If you are calling @catch@ with type
--- @IO Int -> (ArithException -> IO Int) -> IO Int@ then the handler may
--- get run with @DivideByZero@ as an argument, or an @ErrorCall \"urk\"@
--- exception may be propogated further up. If you call it again, you
--- might get a the opposite behaviour. This is ok, because 'catch' is an
--- 'IO' computation.
---
-catch   :: Exception e
-        => IO a         -- ^ The computation to run
-        -> (e -> IO a)  -- ^ Handler to invoke if an exception is raised
-        -> IO a
-catch act = catchException (lazy act)
-
 -- | The function 'catchJust' is like 'catch', but it takes an extra
 -- argument which is an /exception predicate/, a function which
 -- selects which type of exceptions we\'re interested in.
diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs
index e8823e55f0..a70e103952 100644
--- a/libraries/base/GHC/Conc/Sync.hs
+++ b/libraries/base/GHC/Conc/Sync.hs
@@ -280,7 +280,9 @@ forkIO :: IO () -> IO ThreadId
 forkIO action = IO $ \ s ->
    case (fork# action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
  where
-  action_plus = catchException action childHandler
+  -- We must use 'catch' rather than 'catchException' because the action
+  -- could be bottom. #13330
+  action_plus = catch action childHandler
 
 -- | Like 'forkIO', but the child thread is passed a function that can
 -- be used to unmask asynchronous exceptions.  This function is
@@ -328,7 +330,9 @@ forkOn :: Int -> IO () -> IO ThreadId
 forkOn (I# cpu) action = IO $ \ s ->
    case (forkOn# cpu action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
  where
-  action_plus = catchException action childHandler
+  -- We must use 'catch' rather than 'catchException' because the action
+  -- could be bottom. #13330
+  action_plus = catch action childHandler
 
 -- | Like 'forkIOWithUnmask', but the child thread is pinned to the
 -- given CPU, as with 'forkOn'.
@@ -396,7 +400,11 @@ numSparks = IO $ \s -> case numSparks# s of (# s', n #) -> (# s', I# n #)
 foreign import ccall "&enabled_capabilities" enabled_capabilities :: Ptr CInt
 
 childHandler :: SomeException -> IO ()
-childHandler err = catchException (real_handler err) childHandler
+childHandler err = catch (real_handler err) childHandler
+  -- We must use catch here rather than catchException. If the
+  -- raised exception throws an (imprecise) exception, then real_handler err
+  -- will do so as well. If we use catchException here, then we could miss
+  -- that exception.
 
 real_handler :: SomeException -> IO ()
 real_handler se
diff --git a/libraries/base/GHC/Foreign.hs b/libraries/base/GHC/Foreign.hs
index 7d2f915920..6d2f8c1a56 100644
--- a/libraries/base/GHC/Foreign.hs
+++ b/libraries/base/GHC/Foreign.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE BangPatterns #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -159,7 +161,23 @@ withCStringsLen enc strs f = go [] strs
 -- whether or not a character is encodable will, in general, depend on the
 -- context in which it occurs.
 charIsRepresentable :: TextEncoding -> Char -> IO Bool
-charIsRepresentable enc c = withCString enc [c] (fmap (== [c]) . peekCString enc) `catchException` (\e -> let _ = e :: IOException in return False)
+-- We force enc explicitly because `catch` is lazy in its
+-- first argument. We would probably like to force c as well,
+-- but unfortunately worker/wrapper produces very bad code for
+-- that.
+--
+-- TODO If this function is performance-critical, it would probably
+-- pay to use a single-character specialization of withCString. That
+-- would allow worker/wrapper to actually eliminate Char boxes, and
+-- would also get rid of the completely unnecessary cons allocation.
+charIsRepresentable !enc c =
+  withCString enc [c]
+              (\cstr -> do str <- peekCString enc cstr
+                           case str of
+                             [ch] | ch == c -> pure True
+                             _ -> pure False)
+    `catch`
+       \(_ :: IOException) -> pure False
 
 -- auxiliary definitions
 -- ----------------------
diff --git a/libraries/base/GHC/IO.hs b/libraries/base/GHC/IO.hs
index 0737d19cc4..62b3d5c22e 100644
--- a/libraries/base/GHC/IO.hs
+++ b/libraries/base/GHC/IO.hs
@@ -3,6 +3,7 @@
            , BangPatterns
            , RankNTypes
            , MagicHash
+           , ScopedTypeVariables
            , UnboxedTuples
   #-}
 {-# OPTIONS_GHC -funbox-strict-fields #-}
@@ -33,7 +34,7 @@ module GHC.IO (
 
         FilePath,
 
-        catchException, catchAny, throwIO,
+        catch, catchException, catchAny, throwIO,
         mask, mask_, uninterruptibleMask, uninterruptibleMask_,
         MaskingState(..), getMaskingState,
         unsafeUnmask, interruptible,
@@ -113,7 +114,7 @@ type FilePath = String
 -- Primitive catch and throwIO
 
 {-
-catchException used to handle the passing around of the state to the
+catchException/catch used to handle the passing around of the state to the
 action and the handler.  This turned out to be a bad idea - it meant
 that we had to wrap both arguments in thunks so they could be entered
 as normal (remember IO returns an unboxed pair...).
@@ -123,7 +124,7 @@ Now catch# has type
     catch# :: IO a -> (b -> IO a) -> IO a
 
 (well almost; the compiler doesn't know about the IO newtype so we
-have to work around that in the definition of catchException below).
+have to work around that in the definition of catch below).
 -}
 
 -- | Catch an exception in the 'IO' monad.
@@ -132,25 +133,66 @@ have to work around that in the definition of catchException below).
 -- @catchException undefined b == _|_@. See #exceptions_and_strictness#
 -- for details.
 catchException :: Exception e => IO a -> (e -> IO a) -> IO a
-catchException (IO io) handler = IO $ catch# io handler'
+catchException !io handler = catch io handler
+
+-- | This is the simplest of the exception-catching functions.  It
+-- takes a single argument, runs it, and if an exception is raised
+-- the \"handler\" is executed, with the value of the exception passed as an
+-- argument.  Otherwise, the result is returned as normal.  For example:
+--
+-- >   catch (readFile f)
+-- >         (\e -> do let err = show (e :: IOException)
+-- >                   hPutStr stderr ("Warning: Couldn't open " ++ f ++ ": " ++ err)
+-- >                   return "")
+--
+-- Note that we have to give a type signature to @e@, or the program
+-- will not typecheck as the type is ambiguous. While it is possible
+-- to catch exceptions of any type, see the section \"Catching all
+-- exceptions\" (in "Control.Exception") for an explanation of the problems with doing so.
+--
+-- For catching exceptions in pure (non-'IO') expressions, see the
+-- function 'evaluate'.
+--
+-- Note that due to Haskell\'s unspecified evaluation order, an
+-- expression may throw one of several possible exceptions: consider
+-- the expression @(error \"urk\") + (1 \`div\` 0)@.  Does
+-- the expression throw
+-- @ErrorCall \"urk\"@, or @DivideByZero@?
+--
+-- The answer is \"it might throw either\"; the choice is
+-- non-deterministic. If you are catching any type of exception then you
+-- might catch either. If you are calling @catch@ with type
+-- @IO Int -> (ArithException -> IO Int) -> IO Int@ then the handler may
+-- get run with @DivideByZero@ as an argument, or an @ErrorCall \"urk\"@
+-- exception may be propogated further up. If you call it again, you
+-- might get a the opposite behaviour. This is ok, because 'catch' is an
+-- 'IO' computation.
+--
+catch   :: Exception e
+        => IO a         -- ^ The computation to run
+        -> (e -> IO a)  -- ^ Handler to invoke if an exception is raised
+        -> IO a
+-- See #exceptions_and_strictness#.
+catch (IO io) handler = IO $ catch# io handler'
     where handler' e = case fromException e of
                        Just e' -> unIO (handler e')
                        Nothing -> raiseIO# e
 
+
 -- | Catch any 'Exception' type in the 'IO' monad.
 --
 -- Note that this function is /strict/ in the action. That is,
 -- @catchException undefined b == _|_@. See #exceptions_and_strictness# for
 -- details.
 catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a
-catchAny (IO io) handler = IO $ catch# io handler'
+catchAny !(IO io) handler = IO $ catch# io handler'
     where handler' (SomeException e) = unIO (handler e)
 
-
+-- Using catchException here means that if `m` throws an
+-- 'IOError' /as an imprecise exception/, we will not catch
+-- it. No one should really be doing that anyway.
 mplusIO :: IO a -> IO a -> IO a
-mplusIO m n = m `catchIOError` \ _ -> n
-    where catchIOError :: IO a -> (IOError -> IO a) -> IO a
-          catchIOError = catchException
+mplusIO m n = m `catchException` \ (_ :: IOError) -> n
 
 -- | A variant of 'throw' that can only be used within the 'IO' monad.
 --
@@ -387,28 +429,20 @@ evaluate a = IO $ \s -> seq# a s -- NB. see #2273, #5129
 {- $exceptions_and_strictness
 
 Laziness can interact with @catch@-like operations in non-obvious ways (see,
-e.g. GHC Trac #11555). For instance, consider these subtly-different examples,
+e.g. GHC Trac #11555 and #13330). For instance, consider these subtly-different
+examples:
 
 > test1 = Control.Exception.catch (error "uh oh") (\(_ :: SomeException) -> putStrLn "it failed")
 >
 > test2 = GHC.IO.catchException (error "uh oh") (\(_ :: SomeException) -> putStrLn "it failed")
 
-While the first case is always guaranteed to print "it failed", the behavior of
-@test2@ may vary with optimization level.
-
-The unspecified behavior of @test2@ is due to the fact that GHC may assume that
-'catchException' (and the 'catch#' primitive operation which it is built upon)
-is strict in its first argument. This assumption allows the compiler to better
-optimize @catchException@ calls at the expense of deterministic behavior when
-the action may be bottom.
+While @test1@ will print "it failed", @test2@ will print "uh oh".
 
-Namely, the assumed strictness means that exceptions thrown while evaluating the
-action-to-be-executed may not be caught; only exceptions thrown during execution
-of the action will be handled by the exception handler.
+When using 'catchException', exceptions thrown while evaluating the
+action-to-be-executed will not be caught; only exceptions thrown during
+execution of the action will be handled by the exception handler.
 
 Since this strictness is a small optimization and may lead to surprising
 results, all of the @catch@ and @handle@ variants offered by "Control.Exception"
-are lazy in their first argument. If you are certain that that the action to be
-executed won't bottom in performance-sensitive code, you might consider using
-'GHC.IO.catchException' or 'GHC.IO.catchAny' for a small speed-up.
+use 'catch' rather than 'catchException'.
 -}
diff --git a/testsuite/tests/concurrent/should_run/T13330.hs b/testsuite/tests/concurrent/should_run/T13330.hs
new file mode 100644
index 0000000000..ab8effe786
--- /dev/null
+++ b/testsuite/tests/concurrent/should_run/T13330.hs
@@ -0,0 +1,5 @@
+module Main where
+import Control.Concurrent
+import Control.Exception
+
+main = forkIO (error "Successful exception") >> threadDelay 100000
diff --git a/testsuite/tests/concurrent/should_run/T13330.stderr b/testsuite/tests/concurrent/should_run/T13330.stderr
new file mode 100644
index 0000000000..9eecb64567
--- /dev/null
+++ b/testsuite/tests/concurrent/should_run/T13330.stderr
@@ -0,0 +1,3 @@
+T13330: Successful exception
+CallStack (from HasCallStack):
+  error, called at T13330.hs:5:16 in main:Main
diff --git a/testsuite/tests/concurrent/should_run/all.T b/testsuite/tests/concurrent/should_run/all.T
index 87af525e9f..16363ed0b8 100644
--- a/testsuite/tests/concurrent/should_run/all.T
+++ b/testsuite/tests/concurrent/should_run/all.T
@@ -280,3 +280,6 @@ test('hs_try_putmvar003',
      ],
      compile_and_run,
      ['hs_try_putmvar003_c.c'])
+
+# Check forkIO exception determinism under optimization
+test('T13330', normal, compile_and_run, ['-O'])