[Git][ghc/ghc][wip/T18580] base: Fail if `timeout` is used when exceptions are masked

[Ben Gamari]

Ben Gamari pushed to branch wip/T18580 at Glasgow Haskell Compiler / GHC


Commits:
6e409dcf by Ben Gamari at 2020-08-17T13:04:16-04:00
base: Fail if `timeout` is used when exceptions are masked

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

Fixes #18580.

- - - - -


2 changed files:

- libraries/base/System/Timeout.hs
- libraries/base/changelog.md


Changes:

=====================================
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"


=====================================
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



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6e409dcf76e20e48e6365d44797982c8f13e79d0

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6e409dcf76e20e48e6365d44797982c8f13e79d0
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200817/5786e3e5/attachment-0001.html>