module GHC.Conc.Windows
( ensureIOManagerIsRunning
, threadDelay
, registerDelay
, asyncRead
, asyncWrite
, asyncDoProc
, asyncReadBA
, asyncWriteBA
, ConsoleEvent(..)
, win32ConsoleHandler
, toWin32ConsoleEvent
) where
import Control.Monad
import Data.Bits (shiftR)
import Data.Maybe (Maybe(..))
import Data.Typeable
import GHC.Base
import GHC.Conc.Sync
import GHC.Enum (Enum)
import GHC.IO (unsafePerformIO)
import GHC.IORef
import GHC.MVar
import GHC.Num (Num(..))
import GHC.Ptr
import GHC.Read (Read)
import GHC.Real (div, fromIntegral)
import GHC.Show (Show)
import GHC.Word (Word32, Word64)
import GHC.Windows
asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
asyncRead (I# fd) (I# isSock) (I# len) (Ptr buf) =
IO $ \s -> case asyncRead# fd isSock len buf s of
(# s', len#, err# #) -> (# s', (I# len#, I# err#) #)
asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
asyncWrite (I# fd) (I# isSock) (I# len) (Ptr buf) =
IO $ \s -> case asyncWrite# fd isSock len buf s of
(# s', len#, err# #) -> (# s', (I# len#, I# err#) #)
asyncDoProc :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
asyncDoProc (FunPtr proc) (Ptr param) =
IO $ \s -> case asyncDoProc# proc param s of
(# s', _len#, err# #) -> (# s', I# err# #)
asyncReadBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
asyncReadBA fd isSock len off bufB =
asyncRead fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)
asyncWriteBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
asyncWriteBA fd isSock len off bufB =
asyncWrite fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)
threadDelay :: Int -> IO ()
threadDelay time
| threaded = waitForDelayEvent time
| otherwise = IO $ \s ->
case time of { I# time# ->
case delay# time# s of { s' -> (# s', () #)
}}
registerDelay :: Int -> IO (TVar Bool)
registerDelay usecs
| threaded = waitForDelayEventSTM usecs
| otherwise = error "registerDelay: requires -threaded"
foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
waitForDelayEvent :: Int -> IO ()
waitForDelayEvent usecs = do
m <- newEmptyMVar
target <- calculateTarget usecs
atomicModifyIORef pendingDelays (\xs -> (Delay target m : xs, ()))
prodServiceThread
takeMVar m
waitForDelayEventSTM :: Int -> IO (TVar Bool)
waitForDelayEventSTM usecs = do
t <- atomically $ newTVar False
target <- calculateTarget usecs
atomicModifyIORef pendingDelays (\xs -> (DelaySTM target t : xs, ()))
prodServiceThread
return t
calculateTarget :: Int -> IO USecs
calculateTarget usecs = do
now <- getUSecOfDay
return $ now + (fromIntegral usecs)
data DelayReq
= Delay !USecs !(MVar ())
| DelaySTM !USecs !(TVar Bool)
pendingDelays :: IORef [DelayReq]
pendingDelays = unsafePerformIO $ do
m <- newIORef []
sharedCAF m getOrSetGHCConcWindowsPendingDelaysStore
foreign import ccall unsafe "getOrSetGHCConcWindowsPendingDelaysStore"
getOrSetGHCConcWindowsPendingDelaysStore :: Ptr a -> IO (Ptr a)
ioManagerThread :: MVar (Maybe ThreadId)
ioManagerThread = unsafePerformIO $ do
m <- newMVar Nothing
sharedCAF m getOrSetGHCConcWindowsIOManagerThreadStore
foreign import ccall unsafe "getOrSetGHCConcWindowsIOManagerThreadStore"
getOrSetGHCConcWindowsIOManagerThreadStore :: Ptr a -> IO (Ptr a)
ensureIOManagerIsRunning :: IO ()
ensureIOManagerIsRunning
| threaded = startIOManagerThread
| otherwise = return ()
startIOManagerThread :: IO ()
startIOManagerThread = do
modifyMVar_ ioManagerThread $ \old -> do
let create = do t <- forkIO ioManager; return (Just t)
case old of
Nothing -> create
Just t -> do
s <- threadStatus t
case s of
ThreadFinished -> create
ThreadDied -> create
_other -> return (Just t)
insertDelay :: DelayReq -> [DelayReq] -> [DelayReq]
insertDelay d [] = [d]
insertDelay d1 ds@(d2 : rest)
| delayTime d1 <= delayTime d2 = d1 : ds
| otherwise = d2 : insertDelay d1 rest
delayTime :: DelayReq -> USecs
delayTime (Delay t _) = t
delayTime (DelaySTM t _) = t
type USecs = Word64
foreign import ccall unsafe "getUSecOfDay"
getUSecOfDay :: IO USecs
prodding :: IORef Bool
prodding = unsafePerformIO $ do
r <- newIORef False
sharedCAF r getOrSetGHCConcWindowsProddingStore
foreign import ccall unsafe "getOrSetGHCConcWindowsProddingStore"
getOrSetGHCConcWindowsProddingStore :: Ptr a -> IO (Ptr a)
prodServiceThread :: IO ()
prodServiceThread = do
was_set <- atomicModifyIORef prodding $ \b -> (True,b)
unless was_set wakeupIOManager
ioManager :: IO ()
ioManager = do
wakeup <- c_getIOManagerEvent
service_loop wakeup []
service_loop :: HANDLE
-> [DelayReq]
-> IO ()
service_loop wakeup old_delays = do
new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
let delays = foldr insertDelay old_delays new_delays
now <- getUSecOfDay
(delays', timeout) <- getDelay now delays
r <- c_WaitForSingleObject wakeup timeout
case r of
0xffffffff -> do throwGetLastError "service_loop"
0 -> do
r2 <- c_readIOManagerEvent
exit <-
case r2 of
_ | r2 == io_MANAGER_WAKEUP -> return False
_ | r2 == io_MANAGER_DIE -> return True
0 -> return False
_ -> do start_console_handler (r2 `shiftR` 1); return False
unless exit $ service_cont wakeup delays'
_other -> service_cont wakeup delays'
service_cont :: HANDLE -> [DelayReq] -> IO ()
service_cont wakeup delays = do
r <- atomicModifyIORef prodding (\_ -> (False,False))
r `seq` return ()
service_loop wakeup delays
io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word32
io_MANAGER_WAKEUP = 0xffffffff
io_MANAGER_DIE = 0xfffffffe
data ConsoleEvent
= ControlC
| Break
| Close
| Logoff
| Shutdown
deriving (Eq, Ord, Enum, Show, Read, Typeable)
start_console_handler :: Word32 -> IO ()
start_console_handler r =
case toWin32ConsoleEvent r of
Just x -> withMVar win32ConsoleHandler $ \handler -> do
_ <- forkIO (handler x)
return ()
Nothing -> return ()
toWin32ConsoleEvent :: (Eq a, Num a) => a -> Maybe ConsoleEvent
toWin32ConsoleEvent ev =
case ev of
0 -> Just ControlC
1 -> Just Break
2 -> Just Close
5 -> Just Logoff
6 -> Just Shutdown
_ -> Nothing
win32ConsoleHandler :: MVar (ConsoleEvent -> IO ())
win32ConsoleHandler = unsafePerformIO (newMVar (error "win32ConsoleHandler"))
wakeupIOManager :: IO ()
wakeupIOManager = c_sendIOManagerEvent io_MANAGER_WAKEUP
getDelay :: USecs -> [DelayReq] -> IO ([DelayReq], DWORD)
getDelay _ [] = return ([], iNFINITE)
getDelay now all@(d : rest)
= case d of
Delay time m | now >= time -> do
putMVar m ()
getDelay now rest
DelaySTM time t | now >= time -> do
atomically $ writeTVar t True
getDelay now rest
_otherwise ->
let micro_seconds = delayTime d now
milli_seconds = (micro_seconds + 999) `div` 1000
in return (all, fromIntegral milli_seconds)
foreign import ccall unsafe "getIOManagerEvent"
c_getIOManagerEvent :: IO HANDLE
foreign import ccall unsafe "readIOManagerEvent"
c_readIOManagerEvent :: IO Word32
foreign import ccall unsafe "sendIOManagerEvent"
c_sendIOManagerEvent :: Word32 -> IO ()
foreign import stdcall "WaitForSingleObject"
c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD