{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
{-# OPTIONS_HADDOCK not-home #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Conc.POSIX
-- 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)
--
-- Windows I/O manager
--
-- This is the I/O manager based on posix FDs for windows.
-- When using the winio manager these functions may not
-- be used as they will behave in unexpected ways.
--
-- TODO: This manager is currently the default. But we will eventually
-- switch to use winio instead.
--
-----------------------------------------------------------------------------

-- #not-home
module GHC.Conc.POSIX
       ( ensureIOManagerIsRunning
       , interruptIOManager

       -- * Waiting
       , threadDelay
       , registerDelay

       -- * Miscellaneous
       , asyncRead
       , asyncWrite
       , asyncDoProc

       , asyncReadBA
       , asyncWriteBA

       , module GHC.Event.Windows.ConsoleEvent
       ) where


#include "windows_cconv.h"

import Data.Bits (shiftR)
import GHC.Base
import GHC.Clock
import GHC.Conc.Sync
import GHC.Conc.POSIX.Const
import GHC.Event.Windows.ConsoleEvent
import GHC.IO (unsafePerformIO)
import GHC.IORef
import GHC.MVar
import GHC.Num (Num(..))
import GHC.Ptr
import GHC.Real (div, fromIntegral)
import GHC.Word (Word32, Word64)
import GHC.Windows

-- ----------------------------------------------------------------------------
-- Thread waiting

-- Note: threadWaitRead and threadWaitWrite aren't really functional
-- on Win32, but left in there because lib code (still) uses them (the manner
-- in which they're used doesn't cause problems on a Win32 platform though.)

asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
asyncRead :: forall a. Int -> Int -> Int -> Ptr a -> IO (Int, Int)
asyncRead  (I# Int#
fd) (I# Int#
isSock) (I# Int#
len) (Ptr Addr#
buf) =
  (State# RealWorld -> (# State# RealWorld, (Int, Int) #))
-> IO (Int, Int)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, (Int, Int) #))
 -> IO (Int, Int))
-> (State# RealWorld -> (# State# RealWorld, (Int, Int) #))
-> IO (Int, Int)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case Int#
-> Int#
-> Int#
-> Addr#
-> State# RealWorld
-> (# State# RealWorld, Int#, Int# #)
asyncRead# Int#
fd Int#
isSock Int#
len Addr#
buf State# RealWorld
s of
               (# State# RealWorld
s', Int#
len#, Int#
err# #) -> (# State# RealWorld
s', (Int# -> Int
I# Int#
len#, Int# -> Int
I# Int#
err#) #)

asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
asyncWrite :: forall a. Int -> Int -> Int -> Ptr a -> IO (Int, Int)
asyncWrite  (I# Int#
fd) (I# Int#
isSock) (I# Int#
len) (Ptr Addr#
buf) =
  (State# RealWorld -> (# State# RealWorld, (Int, Int) #))
-> IO (Int, Int)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, (Int, Int) #))
 -> IO (Int, Int))
-> (State# RealWorld -> (# State# RealWorld, (Int, Int) #))
-> IO (Int, Int)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case Int#
-> Int#
-> Int#
-> Addr#
-> State# RealWorld
-> (# State# RealWorld, Int#, Int# #)
asyncWrite# Int#
fd Int#
isSock Int#
len Addr#
buf State# RealWorld
s of
               (# State# RealWorld
s', Int#
len#, Int#
err# #) -> (# State# RealWorld
s', (Int# -> Int
I# Int#
len#, Int# -> Int
I# Int#
err#) #)

asyncDoProc :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
asyncDoProc :: forall a. FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
asyncDoProc (FunPtr Addr#
proc) (Ptr Addr#
param) =
    -- the 'length' value is ignored; simplifies implementation of
    -- the async*# primops to have them all return the same result.
  (State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int)
-> (State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case Addr#
-> Addr# -> State# RealWorld -> (# State# RealWorld, Int#, Int# #)
asyncDoProc# Addr#
proc Addr#
param State# RealWorld
s  of
               (# State# RealWorld
s', Int#
_len#, Int#
err# #) -> (# State# RealWorld
s', Int# -> Int
I# Int#
err# #)

-- to aid the use of these primops by the IO Handle implementation,
-- provide the following convenience funs:

-- this better be a pinned byte array!
asyncReadBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
asyncReadBA :: Int
-> Int
-> Int
-> Int
-> MutableByteArray# RealWorld
-> IO (Int, Int)
asyncReadBA Int
fd Int
isSock Int
len Int
off MutableByteArray# RealWorld
bufB =
  Int -> Int -> Int -> Ptr Any -> IO (Int, Int)
forall a. Int -> Int -> Int -> Ptr a -> IO (Int, Int)
asyncRead Int
fd Int
isSock Int
len ((Addr# -> Ptr Any
forall a. Addr# -> Ptr a
Ptr (MutableByteArray# RealWorld -> Addr#
forall d. MutableByteArray# d -> Addr#
mutableByteArrayContents# MutableByteArray# RealWorld
bufB)) Ptr Any -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off)

asyncWriteBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
asyncWriteBA :: Int
-> Int
-> Int
-> Int
-> MutableByteArray# RealWorld
-> IO (Int, Int)
asyncWriteBA Int
fd Int
isSock Int
len Int
off MutableByteArray# RealWorld
bufB =
  Int -> Int -> Int -> Ptr Any -> IO (Int, Int)
forall a. Int -> Int -> Int -> Ptr a -> IO (Int, Int)
asyncWrite Int
fd Int
isSock Int
len ((Addr# -> Ptr Any
forall a. Addr# -> Ptr a
Ptr (MutableByteArray# RealWorld -> Addr#
forall d. MutableByteArray# d -> Addr#
mutableByteArrayContents# MutableByteArray# RealWorld
bufB)) Ptr Any -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off)

-- ----------------------------------------------------------------------------
-- Threaded RTS implementation of threadDelay

-- | 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.
--
threadDelay :: Int -> IO ()
threadDelay :: Int -> IO ()
threadDelay Int
time
  | Bool
threaded  = Int -> IO ()
waitForDelayEvent Int
time
  | Bool
otherwise = (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
        case Int
time of { I# Int#
time# ->
        case Int# -> State# RealWorld -> State# RealWorld
forall d. Int# -> State# d -> State# d
delay# Int#
time# State# RealWorld
s of { State# RealWorld
s' -> (# State# RealWorld
s', () #)
        }}

-- | Set the value of returned TVar 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 :: Int -> IO (TVar Bool)
registerDelay Int
usecs
  | Bool
threaded = Int -> IO (TVar Bool)
waitForDelayEventSTM Int
usecs
  | Bool
otherwise = [Char] -> IO (TVar Bool)
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"registerDelay: requires -threaded"

foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool

waitForDelayEvent :: Int -> IO ()
waitForDelayEvent :: Int -> IO ()
waitForDelayEvent Int
usecs = do
  MVar ()
m <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  USecs
target <- Int -> IO USecs
calculateTarget Int
usecs
  ([DelayReq], [DelayReq])
_ <- IORef [DelayReq]
-> ([DelayReq] -> [DelayReq]) -> IO ([DelayReq], [DelayReq])
forall a. IORef a -> (a -> a) -> IO (a, a)
atomicModifyIORef'_ IORef [DelayReq]
pendingDelays (\[DelayReq]
xs -> USecs -> MVar () -> DelayReq
Delay USecs
target MVar ()
m DelayReq -> [DelayReq] -> [DelayReq]
forall a. a -> [a] -> [a]
: [DelayReq]
xs)
  IO ()
prodServiceThread
  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
m

-- Delays for use in STM
waitForDelayEventSTM :: Int -> IO (TVar Bool)
waitForDelayEventSTM :: Int -> IO (TVar Bool)
waitForDelayEventSTM Int
usecs = do
   TVar Bool
t <- STM (TVar Bool) -> IO (TVar Bool)
forall a. STM a -> IO a
atomically (STM (TVar Bool) -> IO (TVar Bool))
-> STM (TVar Bool) -> IO (TVar Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> STM (TVar Bool)
forall a. a -> STM (TVar a)
newTVar Bool
False
   USecs
target <- Int -> IO USecs
calculateTarget Int
usecs
   ([DelayReq], [DelayReq])
_ <- IORef [DelayReq]
-> ([DelayReq] -> [DelayReq]) -> IO ([DelayReq], [DelayReq])
forall a. IORef a -> (a -> a) -> IO (a, a)
atomicModifyIORef'_ IORef [DelayReq]
pendingDelays (\[DelayReq]
xs -> USecs -> TVar Bool -> DelayReq
DelaySTM USecs
target TVar Bool
t DelayReq -> [DelayReq] -> [DelayReq]
forall a. a -> [a] -> [a]
: [DelayReq]
xs)
   IO ()
prodServiceThread
   TVar Bool -> IO (TVar Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TVar Bool
t

calculateTarget :: Int -> IO USecs
calculateTarget :: Int -> IO USecs
calculateTarget Int
usecs = do
    USecs
now <- IO USecs
getMonotonicUSec
    USecs -> IO USecs
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (USecs -> IO USecs) -> USecs -> IO USecs
forall a b. (a -> b) -> a -> b
$ USecs
now USecs -> USecs -> USecs
forall a. Num a => a -> a -> a
+ (Int -> USecs
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
usecs)

data DelayReq
  = Delay    {-# UNPACK #-} !USecs {-# UNPACK #-} !(MVar ())
  | DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool)

{-# NOINLINE pendingDelays #-}
pendingDelays :: IORef [DelayReq]
pendingDelays :: IORef [DelayReq]
pendingDelays = IO (IORef [DelayReq]) -> IORef [DelayReq]
forall a. IO a -> a
unsafePerformIO (IO (IORef [DelayReq]) -> IORef [DelayReq])
-> IO (IORef [DelayReq]) -> IORef [DelayReq]
forall a b. (a -> b) -> a -> b
$ do
   IORef [DelayReq]
m <- [DelayReq] -> IO (IORef [DelayReq])
forall a. a -> IO (IORef a)
newIORef []
   IORef [DelayReq]
-> (Ptr (IORef [DelayReq]) -> IO (Ptr (IORef [DelayReq])))
-> IO (IORef [DelayReq])
forall a. a -> (Ptr a -> IO (Ptr a)) -> IO a
sharedCAF IORef [DelayReq]
m Ptr (IORef [DelayReq]) -> IO (Ptr (IORef [DelayReq]))
forall a. Ptr a -> IO (Ptr a)
getOrSetGHCConcWindowsPendingDelaysStore

foreign import ccall unsafe "getOrSetGHCConcWindowsPendingDelaysStore"
    getOrSetGHCConcWindowsPendingDelaysStore :: Ptr a -> IO (Ptr a)

{-# NOINLINE ioManagerThread #-}
ioManagerThread :: MVar (Maybe ThreadId)
ioManagerThread :: MVar (Maybe ThreadId)
ioManagerThread = IO (MVar (Maybe ThreadId)) -> MVar (Maybe ThreadId)
forall a. IO a -> a
unsafePerformIO (IO (MVar (Maybe ThreadId)) -> MVar (Maybe ThreadId))
-> IO (MVar (Maybe ThreadId)) -> MVar (Maybe ThreadId)
forall a b. (a -> b) -> a -> b
$ do
   MVar (Maybe ThreadId)
m <- Maybe ThreadId -> IO (MVar (Maybe ThreadId))
forall a. a -> IO (MVar a)
newMVar Maybe ThreadId
forall a. Maybe a
Nothing
   MVar (Maybe ThreadId)
-> (Ptr (MVar (Maybe ThreadId))
    -> IO (Ptr (MVar (Maybe ThreadId))))
-> IO (MVar (Maybe ThreadId))
forall a. a -> (Ptr a -> IO (Ptr a)) -> IO a
sharedCAF MVar (Maybe ThreadId)
m Ptr (MVar (Maybe ThreadId)) -> IO (Ptr (MVar (Maybe ThreadId)))
forall a. Ptr a -> IO (Ptr a)
getOrSetGHCConcWindowsIOManagerThreadStore

foreign import ccall unsafe "getOrSetGHCConcWindowsIOManagerThreadStore"
    getOrSetGHCConcWindowsIOManagerThreadStore :: Ptr a -> IO (Ptr a)

ensureIOManagerIsRunning :: IO ()
ensureIOManagerIsRunning :: IO ()
ensureIOManagerIsRunning
  | Bool
threaded  = IO ()
startIOManagerThread
  | Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

interruptIOManager :: IO ()
interruptIOManager :: IO ()
interruptIOManager = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

startIOManagerThread :: IO ()
startIOManagerThread :: IO ()
startIOManagerThread =
  MVar (Maybe ThreadId)
-> (Maybe ThreadId -> IO (Maybe ThreadId)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe ThreadId)
ioManagerThread ((Maybe ThreadId -> IO (Maybe ThreadId)) -> IO ())
-> (Maybe ThreadId -> IO (Maybe ThreadId)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe ThreadId
old -> do
    let create :: IO (Maybe ThreadId)
create = do ThreadId
t <- IO () -> IO ThreadId
forkIO IO ()
ioManager;
                    ThreadId -> [Char] -> IO ()
labelThread ThreadId
t [Char]
"IOManagerThread";
                    Maybe ThreadId -> IO (Maybe ThreadId)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ThreadId -> Maybe ThreadId
forall a. a -> Maybe a
Just ThreadId
t)
    case Maybe ThreadId
old of
      Maybe ThreadId
Nothing -> IO (Maybe ThreadId)
create
      Just ThreadId
t  -> do
        ThreadStatus
s <- ThreadId -> IO ThreadStatus
threadStatus ThreadId
t
        case ThreadStatus
s of
          ThreadStatus
ThreadFinished -> IO (Maybe ThreadId)
create
          ThreadStatus
ThreadDied     -> IO (Maybe ThreadId)
create
          ThreadStatus
_other         -> Maybe ThreadId -> IO (Maybe ThreadId)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ThreadId -> Maybe ThreadId
forall a. a -> Maybe a
Just ThreadId
t)

insertDelay :: DelayReq -> [DelayReq] -> [DelayReq]
insertDelay :: DelayReq -> [DelayReq] -> [DelayReq]
insertDelay DelayReq
d [] = [DelayReq
d]
insertDelay DelayReq
d1 ds :: [DelayReq]
ds@(DelayReq
d2 : [DelayReq]
rest)
  | DelayReq -> USecs
delayTime DelayReq
d1 USecs -> USecs -> Bool
forall a. Ord a => a -> a -> Bool
<= DelayReq -> USecs
delayTime DelayReq
d2 = DelayReq
d1 DelayReq -> [DelayReq] -> [DelayReq]
forall a. a -> [a] -> [a]
: [DelayReq]
ds
  | Bool
otherwise                    = DelayReq
d2 DelayReq -> [DelayReq] -> [DelayReq]
forall a. a -> [a] -> [a]
: DelayReq -> [DelayReq] -> [DelayReq]
insertDelay DelayReq
d1 [DelayReq]
rest

delayTime :: DelayReq -> USecs
delayTime :: DelayReq -> USecs
delayTime (Delay USecs
t MVar ()
_) = USecs
t
delayTime (DelaySTM USecs
t TVar Bool
_) = USecs
t

type USecs = Word64

getMonotonicUSec :: IO USecs
getMonotonicUSec :: IO USecs
getMonotonicUSec = (USecs -> USecs) -> IO USecs -> IO USecs
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (USecs -> USecs -> USecs
forall a. Integral a => a -> a -> a
`div` USecs
1000) IO USecs
getMonotonicTimeNSec

{-# NOINLINE prodding #-}
prodding :: IORef Bool
prodding :: IORef Bool
prodding = IO (IORef Bool) -> IORef Bool
forall a. IO a -> a
unsafePerformIO (IO (IORef Bool) -> IORef Bool) -> IO (IORef Bool) -> IORef Bool
forall a b. (a -> b) -> a -> b
$ do
   IORef Bool
r <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
   IORef Bool
-> (Ptr (IORef Bool) -> IO (Ptr (IORef Bool))) -> IO (IORef Bool)
forall a. a -> (Ptr a -> IO (Ptr a)) -> IO a
sharedCAF IORef Bool
r Ptr (IORef Bool) -> IO (Ptr (IORef Bool))
forall a. Ptr a -> IO (Ptr a)
getOrSetGHCConcWindowsProddingStore

foreign import ccall unsafe "getOrSetGHCConcWindowsProddingStore"
    getOrSetGHCConcWindowsProddingStore :: Ptr a -> IO (Ptr a)

prodServiceThread :: IO ()
prodServiceThread :: IO ()
prodServiceThread = do
  -- NB. use atomicSwapIORef here, otherwise there are race
  -- conditions in which prodding is left at True but the server is
  -- blocked in select().
  Bool
was_set <- IORef Bool -> Bool -> IO Bool
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Bool
prodding Bool
True
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
was_set) IO ()
wakeupIOManager

-- ----------------------------------------------------------------------------
-- Windows IO manager thread

ioManager :: IO ()
ioManager :: IO ()
ioManager = do
  HANDLE
wakeup <- IO HANDLE
c_getIOManagerEvent
  HANDLE -> [DelayReq] -> IO ()
service_loop HANDLE
wakeup []

service_loop :: HANDLE          -- read end of pipe
             -> [DelayReq]      -- current delay requests
             -> IO ()

service_loop :: HANDLE -> [DelayReq] -> IO ()
service_loop HANDLE
wakeup [DelayReq]
old_delays = do
  -- pick up new delay requests
  [DelayReq]
new_delays <- IORef [DelayReq] -> [DelayReq] -> IO [DelayReq]
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef [DelayReq]
pendingDelays []
  let  delays :: [DelayReq]
delays = (DelayReq -> [DelayReq] -> [DelayReq])
-> [DelayReq] -> [DelayReq] -> [DelayReq]
forall a b. (a -> b -> b) -> b -> [a] -> b
foldr DelayReq -> [DelayReq] -> [DelayReq]
insertDelay [DelayReq]
old_delays [DelayReq]
new_delays

  USecs
now <- IO USecs
getMonotonicUSec
  ([DelayReq]
delays', DWORD
timeout) <- USecs -> [DelayReq] -> IO ([DelayReq], DWORD)
getDelay USecs
now [DelayReq]
delays

  DWORD
r <- HANDLE -> DWORD -> IO DWORD
c_WaitForSingleObject HANDLE
wakeup DWORD
timeout
  case DWORD
r of
    DWORD
0xffffffff -> [Char] -> IO ()
forall a. [Char] -> IO a
throwGetLastError [Char]
"service_loop"
    DWORD
0 -> do
        DWORD
r2 <- IO DWORD
c_readIOManagerEvent
        Bool
exit <-
              case DWORD
r2 of
                DWORD
_ | DWORD
r2 DWORD -> DWORD -> Bool
forall a. Eq a => a -> a -> Bool
== DWORD
io_MANAGER_WAKEUP -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                DWORD
_ | DWORD
r2 DWORD -> DWORD -> Bool
forall a. Eq a => a -> a -> Bool
== DWORD
io_MANAGER_DIE    -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                DWORD
0 -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False -- spurious wakeup
                DWORD
_ -> do DWORD -> IO ()
start_console_handler (DWORD
r2 DWORD -> Int -> DWORD
forall a. Bits a => a -> Int -> a
`shiftR` Int
1); Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
exit) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HANDLE -> [DelayReq] -> IO ()
service_cont HANDLE
wakeup [DelayReq]
delays'

    DWORD
_other -> HANDLE -> [DelayReq] -> IO ()
service_cont HANDLE
wakeup [DelayReq]
delays' -- probably timeout

service_cont :: HANDLE -> [DelayReq] -> IO ()
service_cont :: HANDLE -> [DelayReq] -> IO ()
service_cont HANDLE
wakeup [DelayReq]
delays = do
  Bool
_ <- IORef Bool -> Bool -> IO Bool
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Bool
prodding Bool
False
  HANDLE -> [DelayReq] -> IO ()
service_loop HANDLE
wakeup [DelayReq]
delays

wakeupIOManager :: IO ()
wakeupIOManager :: IO ()
wakeupIOManager = DWORD -> IO ()
c_sendIOManagerEvent DWORD
io_MANAGER_WAKEUP

-- Walk the queue of pending delays, waking up any that have passed
-- and return the smallest delay to wait for.  The queue of pending
-- delays is kept ordered.
getDelay :: USecs -> [DelayReq] -> IO ([DelayReq], DWORD)
getDelay :: USecs -> [DelayReq] -> IO ([DelayReq], DWORD)
getDelay USecs
_   [] = ([DelayReq], DWORD) -> IO ([DelayReq], DWORD)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], DWORD
iNFINITE)
getDelay USecs
now all :: [DelayReq]
all@(DelayReq
d : [DelayReq]
rest)
  = case DelayReq
d of
     Delay USecs
time MVar ()
m | USecs
now USecs -> USecs -> Bool
forall a. Ord a => a -> a -> Bool
>= USecs
time -> do
        MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
m ()
        USecs -> [DelayReq] -> IO ([DelayReq], DWORD)
getDelay USecs
now [DelayReq]
rest
     DelaySTM USecs
time TVar Bool
t | USecs
now USecs -> USecs -> Bool
forall a. Ord a => a -> a -> Bool
>= USecs
time -> do
        STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
t Bool
True
        USecs -> [DelayReq] -> IO ([DelayReq], DWORD)
getDelay USecs
now [DelayReq]
rest
     DelayReq
_otherwise ->
        -- delay is in millisecs for WaitForSingleObject
        let micro_seconds :: USecs
micro_seconds = DelayReq -> USecs
delayTime DelayReq
d USecs -> USecs -> USecs
forall a. Num a => a -> a -> a
- USecs
now
            milli_seconds :: USecs
milli_seconds = (USecs
micro_seconds USecs -> USecs -> USecs
forall a. Num a => a -> a -> a
+ USecs
999) USecs -> USecs -> USecs
forall a. Integral a => a -> a -> a
`div` USecs
1000
        in ([DelayReq], DWORD) -> IO ([DelayReq], DWORD)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DelayReq]
all, USecs -> DWORD
forall a b. (Integral a, Num b) => a -> b
fromIntegral USecs
milli_seconds)

foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c)
  c_getIOManagerEvent :: IO HANDLE

foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c)
  c_readIOManagerEvent :: IO Word32

foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c)
  c_sendIOManagerEvent :: Word32 -> IO ()

foreign import WINDOWS_CCONV "WaitForSingleObject"
   c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD