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