base: Fail if `timeout` is used when exceptions are maskedwip/T18580

As pointed out in #18580, `timeout`'s implementation assumes that
exceptions will be handled. Document and assert this precondition.

Fixes #18580.

2 files changed, 21 insertions, 2 deletions

diff --git a/libraries/base/System/Timeout.hs b/libraries/base/System/Timeout.hs
index cc89bfed40..464864e3b9 100644
--- a/libraries/base/System/Timeout.hs
+++ b/libraries/base/System/Timeout.hs
@@ -27,8 +27,10 @@ import Control.Concurrent
 import Control.Exception   (Exception(..), handleJust, bracket,
                             uninterruptibleMask_,
                             asyncExceptionToException,
-                            asyncExceptionFromException)
+                            asyncExceptionFromException,
+                            getMaskingState, MaskingState(..))
 import Data.Unique         (Unique, newUnique)
+import GHC.Stack.Types     (HasCallStack)
 
 -- An internal type that is thrown as a dynamic exception to
 -- interrupt the running IO computation when the timeout has
@@ -89,12 +91,16 @@ instance Exception Timeout where
 -- Note that 'timeout' cancels the computation by throwing it the 'Timeout'
 -- exception. Consequently blanket exception handlers (e.g. catching
 -- 'SomeException') within the computation will break the timeout behavior.
-timeout :: Int -> IO a -> IO (Maybe a)
+-- Moreover, 'timeout' cannot be used when in a context enclosed by
+-- by 'Control.Exception.uninterruptibleMask'.
+timeout :: HasCallStack => Int -> IO a -> IO (Maybe a)
 timeout n f
     | n <  0    = fmap Just f
     | n == 0    = return Nothing
 #if !defined(mingw32_HOST_OS)
     | rtsSupportsBoundThreads = do
+        checkNonUninterruptibleMask
+
         -- In the threaded RTS, we use the Timer Manager to delay the
         -- (fairly expensive) 'forkIO' call until the timeout has expired.
         --
@@ -125,6 +131,7 @@ timeout n f
                             (\_ -> fmap Just f))
 #endif
     | otherwise = do
+        checkNonUninterruptibleMask
         pid <- myThreadId
         ex  <- fmap Timeout newUnique
         handleJust (\e -> if e == ex then Just () else Nothing)
@@ -134,3 +141,9 @@ timeout n f
                             (uninterruptibleMask_ . killThread)
                             (\_ -> fmap Just f))
         -- #7719 explains why we need uninterruptibleMask_ above.
+  where
+    checkNonUninterruptibleMask :: HasCallStack => IO ()
+    checkNonUninterruptibleMask = do
+      maskingState <- getMaskingState
+      when (maskingState == Unmasked) $
+        error "System.Timeout.timeout called with exceptions uninterruptibly masked"
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index be86901ff4..e66bdb89f0 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -1,5 +1,11 @@
 # Changelog for [`base` package](http://hackage.haskell.org/package/base)
 
+## 4.16.0.0 *TBA*
+
+  * `System.Timeout.timeout` now throws an error if called in a context where
+    exceptions have been masked since its implementation relies on exceptions to
+    interrupt its sub-computation (fixes #18580).
+
 ## 4.15.0.0 *TBA*
 
   * `openFile` now calls the `open` system call with an `interruptible` FFI