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
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
|
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP
, NoImplicitPrelude
, MagicHash
, UnboxedTuples
#-}
{-# OPTIONS_HADDOCK not-home #-}
-----------------------------------------------------------------------------
-- |
-- Module : GHC.Conc.IO
-- Copyright : (c) The University of Glasgow, 1994-2002
-- License : see libraries/base/LICENSE
--
-- Maintainer : cvs-ghc@haskell.org
-- Stability : internal
-- Portability : non-portable (GHC extensions)
--
-- Basic concurrency stuff.
--
-----------------------------------------------------------------------------
-- No: #hide, because bits of this module are exposed by the stm package.
-- However, we don't want this module to be the home location for the
-- bits it exports, we'd rather have Control.Concurrent and the other
-- higher level modules be the home. Hence: #not-home
module GHC.Conc.IO
( ensureIOManagerIsRunning
, ioManagerCapabilitiesChanged
, interruptIOManager
-- * Waiting
, threadDelay
, registerDelay
, threadWaitRead
, threadWaitWrite
, threadWaitReadSTM
, threadWaitWriteSTM
, closeFdWith
#if defined(mingw32_HOST_OS)
, asyncRead
, asyncWrite
, asyncDoProc
, asyncReadBA
, asyncWriteBA
, ConsoleEvent(..)
, win32ConsoleHandler
, toWin32ConsoleEvent
#endif
) where
import Foreign
import GHC.Base
import GHC.Conc.Sync as Sync
import GHC.Real ( fromIntegral )
import System.Posix.Types
#if defined(mingw32_HOST_OS)
import qualified GHC.Conc.Windows as Windows
import GHC.IO.SubSystem
import GHC.Conc.Windows (asyncRead, asyncWrite, asyncDoProc, asyncReadBA,
asyncWriteBA, ConsoleEvent(..), win32ConsoleHandler,
toWin32ConsoleEvent)
#else
import qualified GHC.Event.Thread as Event
#endif
ensureIOManagerIsRunning :: IO ()
#if !defined(mingw32_HOST_OS)
ensureIOManagerIsRunning = Event.ensureIOManagerIsRunning
#else
ensureIOManagerIsRunning = Windows.ensureIOManagerIsRunning
#endif
-- | Interrupts the current wait of the I/O manager if it is currently blocked.
-- This instructs it to re-read how much it should wait and to process any
-- pending events.
--
-- @since 4.15
interruptIOManager :: IO ()
#if !defined(mingw32_HOST_OS)
interruptIOManager = return ()
#else
interruptIOManager = Windows.interruptIOManager
#endif
ioManagerCapabilitiesChanged :: IO ()
#if !defined(mingw32_HOST_OS)
ioManagerCapabilitiesChanged = Event.ioManagerCapabilitiesChanged
#else
ioManagerCapabilitiesChanged = return ()
#endif
-- | Block the current thread until data is available to read on the
-- given file descriptor (GHC only).
--
-- This will throw an 'Prelude.IOError' if the file descriptor was closed
-- while this thread was blocked. To safely close a file descriptor
-- that has been used with 'threadWaitRead', use 'closeFdWith'.
threadWaitRead :: Fd -> IO ()
threadWaitRead fd
#if !defined(mingw32_HOST_OS)
| threaded = Event.threadWaitRead fd
#endif
| otherwise = IO $ \s ->
case fromIntegral fd of { I# fd# ->
case waitRead# fd# s of { s' -> (# s', () #)
}}
-- | Block the current thread until data can be written to the
-- given file descriptor (GHC only).
--
-- This will throw an 'Prelude.IOError' if the file descriptor was closed
-- while this thread was blocked. To safely close a file descriptor
-- that has been used with 'threadWaitWrite', use 'closeFdWith'.
threadWaitWrite :: Fd -> IO ()
threadWaitWrite fd
#if !defined(mingw32_HOST_OS)
| threaded = Event.threadWaitWrite fd
#endif
| otherwise = IO $ \s ->
case fromIntegral fd of { I# fd# ->
case waitWrite# fd# s of { s' -> (# s', () #)
}}
-- | Returns an STM action that can be used to wait for data
-- to read from a file descriptor. The second returned value
-- is an IO action that can be used to deregister interest
-- in the file descriptor.
threadWaitReadSTM :: Fd -> IO (Sync.STM (), IO ())
threadWaitReadSTM fd
#if !defined(mingw32_HOST_OS)
| threaded = Event.threadWaitReadSTM fd
#endif
| otherwise = do
m <- Sync.newTVarIO False
t <- Sync.forkIO $ do
threadWaitRead fd
Sync.atomically $ Sync.writeTVar m True
let waitAction = do b <- Sync.readTVar m
if b then return () else retry
let killAction = Sync.killThread t
return (waitAction, killAction)
-- | Returns an STM action that can be used to wait until data
-- can be written to a file descriptor. The second returned value
-- is an IO action that can be used to deregister interest
-- in the file descriptor.
threadWaitWriteSTM :: Fd -> IO (Sync.STM (), IO ())
threadWaitWriteSTM fd
#if !defined(mingw32_HOST_OS)
| threaded = Event.threadWaitWriteSTM fd
#endif
| otherwise = do
m <- Sync.newTVarIO False
t <- Sync.forkIO $ do
threadWaitWrite fd
Sync.atomically $ Sync.writeTVar m True
let waitAction = do b <- Sync.readTVar m
if b then return () else retry
let killAction = Sync.killThread t
return (waitAction, killAction)
-- | Close a file descriptor in a concurrency-safe way (GHC only). If
-- you are using 'threadWaitRead' or 'threadWaitWrite' to perform
-- blocking I\/O, you /must/ use this function to close file
-- descriptors, or blocked threads may not be woken.
--
-- Any threads that are blocked on the file descriptor via
-- 'threadWaitRead' or 'threadWaitWrite' will be unblocked by having
-- IO exceptions thrown.
closeFdWith :: (Fd -> IO ()) -- ^ Low-level action that performs the real close.
-> Fd -- ^ File descriptor to close.
-> IO ()
closeFdWith close fd
#if !defined(mingw32_HOST_OS)
| threaded = Event.closeFdWith close fd
#endif
| otherwise = close fd
-- | Suspends the current thread for a given number of microseconds
-- (GHC only).
--
-- There is no guarantee that the thread will be rescheduled promptly
-- when the delay has expired, but the thread will never continue to
-- run /earlier/ than specified.
--
-- Be careful not to exceed @maxBound :: Int@, which on 32-bit machines is only
-- 2147483647 μs, less than 36 minutes.
-- Consider using @Control.Concurrent.Thread.Delay.delay@ from @unbounded-delays@ package.
threadDelay :: Int -> IO ()
threadDelay time
#if defined(mingw32_HOST_OS)
| isWindowsNativeIO = Windows.threadDelay time
| threaded = Windows.threadDelay time
#else
| threaded = Event.threadDelay time
#endif
| otherwise = IO $ \s ->
case time of { I# time# ->
case delay# time# s of { s' -> (# s', () #)
}}
-- | Switch the value of returned 'TVar' from initial value 'False' to 'True'
-- after a given number of microseconds. The caveats associated with
-- 'threadDelay' also apply.
--
-- Be careful not to exceed @maxBound :: Int@, which on 32-bit machines is only
-- 2147483647 μs, less than 36 minutes.
--
registerDelay :: Int -> IO (TVar Bool)
registerDelay usecs
#if defined(mingw32_HOST_OS)
| isWindowsNativeIO = Windows.registerDelay usecs
| threaded = Windows.registerDelay usecs
#else
| threaded = Event.registerDelay usecs
#endif
| otherwise = errorWithoutStackTrace "registerDelay: requires -threaded"
foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
|
