1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE Safe #-}
-------------------------------------------------------------------------------
-- |
-- Module : System.Timeout
-- Copyright : (c) The University of Glasgow 2007
-- License : BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : stable
-- Portability : non-portable
--
-- Attach a timeout event to arbitrary 'IO' computations.
--
-------------------------------------------------------------------------------
-- TODO: Inspect is still suitable.
module System.Timeout ( Timeout, timeout ) where
#if !defined(mingw32_HOST_OS) && !defined(js_HOST_ARCH)
import Control.Monad
import GHC.Event (getSystemTimerManager,
registerTimeout, unregisterTimeout)
#endif
import Control.Concurrent
import Control.Exception (Exception(..), handleJust, bracket,
uninterruptibleMask_,
asyncExceptionToException,
asyncExceptionFromException)
import Data.Unique (Unique, newUnique)
-- $setup
-- >>> import Prelude
-- >>> import Control.Concurrent (threadDelay)
-- An internal type that is thrown as a dynamic exception to
-- interrupt the running IO computation when the timeout has
-- expired.
-- | An exception thrown to a thread by 'timeout' to interrupt a timed-out
-- computation.
--
-- @since 4.0
newtype Timeout = Timeout Unique deriving Eq
-- | @since 4.0
instance Show Timeout where
show _ = "<<timeout>>"
-- Timeout is a child of SomeAsyncException
-- | @since 4.7.0.0
instance Exception Timeout where
toException = asyncExceptionToException
fromException = asyncExceptionFromException
-- |Wrap an 'IO' computation to time out and return @Nothing@ in case no result
-- is available within @n@ microseconds (@1\/10^6@ seconds). In case a result
-- is available before the timeout expires, @Just a@ is returned. A negative
-- timeout interval means \"wait indefinitely\". When specifying long timeouts,
-- be careful not to exceed @maxBound :: Int@, which on 32-bit machines is only
-- 2147483647 μs, less than 36 minutes.
-- Consider using @Control.Concurrent.Timeout.timeout@ from @unbounded-delays@ package.
--
-- >>> timeout 1000000 (threadDelay 1000 *> pure "finished on time")
-- Just "finished on time"
--
-- >>> timeout 10000 (threadDelay 100000 *> pure "finished on time")
-- Nothing
--
-- The design of this combinator was guided by the objective that @timeout n f@
-- should behave exactly the same as @f@ as long as @f@ doesn't time out. This
-- means that @f@ has the same 'myThreadId' it would have without the timeout
-- wrapper. Any exceptions @f@ might throw cancel the timeout and propagate
-- further up. It also possible for @f@ to receive exceptions thrown to it by
-- another thread.
--
-- A tricky implementation detail is the question of how to abort an @IO@
-- computation. This combinator relies on asynchronous exceptions internally
-- (namely throwing the computation the 'Timeout' exception). The technique
-- works very well for computations executing inside of the Haskell runtime
-- system, but it doesn't work at all for non-Haskell code. Foreign function
-- calls, for example, cannot be timed out with this combinator simply because
-- an arbitrary C function cannot receive asynchronous exceptions. When
-- @timeout@ is used to wrap an FFI call that blocks, no timeout event can be
-- delivered until the FFI call returns, which pretty much negates the purpose
-- of the combinator. In practice, however, this limitation is less severe than
-- it may sound. Standard I\/O functions like 'System.IO.hGetBuf',
-- 'System.IO.hPutBuf', Network.Socket.accept, or 'System.IO.hWaitForInput'
-- appear to be blocking, but they really don't because the runtime system uses
-- scheduling mechanisms like @select(2)@ to perform asynchronous I\/O, so it
-- is possible to interrupt standard socket I\/O or file I\/O using this
-- combinator.
---
-- 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)
timeout n f
| n < 0 = fmap Just f
| n == 0 = return Nothing
#if !defined(mingw32_HOST_OS) && !defined(js_HOST_ARCH)
| rtsSupportsBoundThreads = do
-- In the threaded RTS, we use the Timer Manager to delay the
-- (fairly expensive) 'forkIO' call until the timeout has expired.
--
-- An additional thread is required for the actual delivery of
-- the Timeout exception because killThread (or another throwTo)
-- is the only way to reliably interrupt a throwTo in flight.
pid <- myThreadId
ex <- fmap Timeout newUnique
tm <- getSystemTimerManager
-- 'lock' synchronizes the timeout handler and the main thread:
-- * the main thread can disable the handler by writing to 'lock';
-- * the handler communicates the spawned thread's id through 'lock'.
-- These two cases are mutually exclusive.
lock <- newEmptyMVar
let handleTimeout = do
v <- isEmptyMVar lock
when v $ void $ forkIOWithUnmask $ \unmask -> unmask $ do
v2 <- tryPutMVar lock =<< myThreadId
when v2 $ throwTo pid ex
cleanupTimeout key = uninterruptibleMask_ $ do
v <- tryPutMVar lock undefined
if v then unregisterTimeout tm key
else takeMVar lock >>= killThread
handleJust (\e -> if e == ex then Just () else Nothing)
(\_ -> return Nothing)
(bracket (registerTimeout tm n handleTimeout)
cleanupTimeout
(\_ -> fmap Just f))
#endif
| otherwise = do
pid <- myThreadId
ex <- fmap Timeout newUnique
handleJust (\e -> if e == ex then Just () else Nothing)
(\_ -> return Nothing)
(bracket (forkIOWithUnmask $ \unmask ->
unmask $ threadDelay n >> throwTo pid ex)
(uninterruptibleMask_ . killThread)
(\_ -> fmap Just f))
-- #7719 explains why we need uninterruptibleMask_ above.
|
