{-# LINE 1 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}

-------------------------------------------------------------------------------

-- |

-- Module      :  GHC.Internal.Event.Windows

-- Copyright   :  (c) Tamar Christina 2018

-- License     :  BSD-style (see the file libraries/base/LICENSE)

--

-- Maintainer  :  libraries@haskell.org

-- Stability   :  stable

-- Portability :  non-portable

--

-- WinIO Windows event manager.

--

-------------------------------------------------------------------------------


module GHC.Internal.Event.Windows (
    -- * Manager

    Manager,
    getSystemManager,
    interruptSystemManager,
    wakeupIOManager,
    processRemoteCompletion,

    -- * Overlapped I/O

    associateHandle,
    associateHandle',
    withOverlapped,
    withOverlappedEx,
    StartCallback,
    StartIOCallback,
    CbResult(..),
    CompletionCallback,
    LPOVERLAPPED,

    -- * Timeouts

    TimeoutCallback,
    TimeoutKey,
    Seconds,
    registerTimeout,
    updateTimeout,
    unregisterTimeout,

    -- * Utilities

    withException,
    ioSuccess,
    ioFailed,
    ioFailedAny,
    getLastError,

    -- * I/O Result type

    IOResult(..),

    -- * I/O Event notifications

    HandleData (..), -- seal for release

    HandleKey (handleValue),
    registerHandle,
    unregisterHandle,

    -- * Console events

    module GHC.Internal.Event.Windows.ConsoleEvent
) where

-- #define DEBUG 1


-- #define DEBUG_TRACE 1







-- There doesn't seem to be  GHC.* import for these

import GHC.Internal.Control.Concurrent.MVar (modifyMVar)
import GHC.Internal.Data.Semigroup.Internal (stimesMonoid)
import GHC.Internal.Data.Foldable (mapM_, length, forM_)
import GHC.Internal.Data.Maybe (isJust, maybe)

import GHC.Internal.Event.Windows.Clock   (Clock, Seconds, getClock, getTime)
import GHC.Internal.Event.Windows.FFI     (LPOVERLAPPED, OVERLAPPED_ENTRY(..),
                                  CompletionData(..), CompletionCallback,
                                  withRequest)
import GHC.Internal.Event.Windows.ManagedThreadPool
import GHC.Internal.Event.Internal.Types
import GHC.Internal.Event.Unique
import GHC.Internal.Event.TimeOut
import GHC.Internal.Event.Windows.ConsoleEvent
import qualified GHC.Internal.Event.Windows.FFI    as FFI
import qualified GHC.Internal.Event.PSQ            as Q
import qualified GHC.Internal.Event.IntTable       as IT
import qualified GHC.Internal.Event.Internal as I

import GHC.Internal.MVar
import GHC.Internal.Exception as E
import GHC.Internal.IORef
import GHC.Internal.Maybe
import GHC.Internal.Ptr
import GHC.Internal.Word
import GHC.Internal.Data.OldList (deleteBy)
import qualified GHC.Internal.Event.Array    as A
import GHC.Internal.Base
import GHC.Internal.Conc.Bound
import GHC.Internal.Conc.Sync
import GHC.Internal.IO
import GHC.Internal.Num
import GHC.Internal.Real
import GHC.Internal.Bits
import GHC.Internal.Stable
import GHC.Internal.Enum (maxBound)
import GHC.Internal.Windows
import GHC.Internal.List (null)
import GHC.Internal.Text.Show
import GHC.Internal.Foreign.Ptr
import GHC.Internal.Foreign.Marshal.Utils
import GHC.Internal.Foreign.Storable
import GHC.Internal.Foreign.Marshal.Alloc
import GHC.Internal.Foreign.Marshal.Array


{-# LINE 131 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}

import qualified GHC.Internal.Windows as Win32


{-# LINE 137 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}

-- Note [WINIO Manager design]

-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~

-- This file contains the Windows I//O manager. Windows's IO subsystem is by

-- design fully asynchronous, however there are multiple ways and interfaces

-- to the async methods.

--

-- The chosen Async interface for this implementation is using Completion Ports

-- See also Note [Completion Ports]. The I/O manager uses a new interface added

-- in Windows Vista called `GetQueuedCompletionStatusEx` which allows us to

-- service multiple requests in one go.

--

-- See https://docs.microsoft.com/en-us/windows-hardware/drivers/kernel/overview-of-the-windows-i-o-model

-- and https://www.microsoftpressstore.com/articles/article.aspx?p=2201309&seqNum=3

--

-- In order to understand this file, here is what you should know:

-- We're using relatively new APIs that allow us to service multiple requests at

-- the same time using one OS thread.  This happens using so called Completion

-- ports.  All I/O actions get associated with one and the same completion port.

--

-- The I/O manager itself has two mode of operation:

-- 1) Threaded: We have N dedicated OS threads in the Haskell world that service

--    completion requests. Everything is Handled 100% in view of the runtime.

--    Whenever the OS has completions that need to be serviced it wakes up one

--    one of the OS threads that are blocked in GetQueuedCompletionStatusEx and

--    lets it proceed  with the list of completions that are finished. If more

--    completions finish before the first list is done being processed then

--    another thread is woken up.  These threads are associated with the I/O

--    manager through the completion port.  If a thread blocks for any reason the

--    OS I/O manager will wake up another thread blocked in GetQueuedCompletionStatusEx

--    from the pool to finish processing the remaining entries.  This worker thread

--    must be able to handle the

--    fact that something else has finished the remainder of their queue or must

--    have a guarantee to never block.  In this implementation we strive to

--    never block.   This is achieved by not having the worker threads call out

--    to any user code, and to have the MVar synchronization primitive never

--    block.   This means if the port is full the message is lost, however we

--    have an invariant that the port can never be full and have a waiting

--    receiver.  As such, dropping the message does not change anything as there

--    will never be anyone to receive it. e.g. it is an impossible situation to

--    land in.

--    Note that it is valid (and perhaps expected) that at times two workers

--    will receive the same requests to handle. We deal with this by using

--    atomic operations to prevent race conditions. See processCompletion

--    for details.

-- 2) Non-threaded: We don't have any dedicated Haskell threads servicing

--    I/O Requests. Instead we have an OS thread inside the RTS that gets

--    notified of new requests and does the servicing.  When a request completes

--    a Haskell thread is scheduled to run to finish off the processing of any

--    completed requests. See Note [Non-Threaded WINIO design].

--

-- These two modes of operations share the majority of the code and so they both

-- support the same operations and fixing one will fix the other.

-- Unlike MIO, we don't threat network I/O any differently than file I/O. Hence

-- any network specific code is now only in the network package.

--

-- See also Note [Completion Ports] which has some of the details which

-- informed this design.

--

-- Note [Threaded WINIO design]

-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~

-- The threaded WiNIO is designed around a simple blocking call that's called in

-- a service loop in a dedicated thread: `GetQueuedCompletionStatusEx`.

-- as such the loop is reasonably simple.  We're either servicing finished

-- requests or blocking in `getQueuedCompletionStatusEx` waiting for new

-- requests to arrive.

--

-- Each time a Handle is made three important things happen that affect the I/O

-- manager design:

-- 1) Files are opened with the `FILE_FLAG_OVERLAPPED` flag, which instructs the

--    OS that we will be doing purely asynchronous requests. See

--    `GHC.Internal.IO.Windows.Handle.openFile`.  They are also opened with

--    `FILE_FLAG_SEQUENTIAL_SCAN` to indicate to the OS that we want to optimize

--    the access of the file for sequential access. (e.g. equivalent to MADVISE)

-- 2) The created handle is associated with the I/O manager's completion port.

--    This allows the I/O manager to be able to service I/O events from this

--    handle.  See `associateHandle`.

-- 3) File handles are additionally modified with two optimization flags:

--

--    FILE_SKIP_COMPLETION_PORT_ON_SUCCESS: If the request can be serviced

--    immediately, then do not queue the IRP (IO Request Packet) into the I/O

--    manager waiting for us to service it later.  Instead service it

--    immediately in the same call.  This is beneficial for two reasons:

--    1) We don't have to block in the Haskell RTS.

--    2) We save a bunch of work in the OS's I/O subsystem.

--    The downside is though that we have to do a bunch of work to handle these

--    cases.  This is abstracted away from the user by the `withOverlapped`

--    function.

--    This together with the buffering strategy mentioned above means we

--    actually skip the I/O manager on quite a lot of I/O requests due to the

--    value being in the cache.  Because of the Lazy I/O in Haskell, the time

--    to read and decode the buffer of bytes is usually longer than the OS needs

--    to read the next chunk, so we hit the FAST_IO IRP quite often.

--

--    FILE_SKIP_SET_EVENT_ON_HANDLE: Since we will not be using an event object

--    to monitor asynchronous completions, don't bother updating or checking for

--    one.  This saves some precious cycles, especially on operations with very

--    high number of I/O operations (e.g. servers.)

--

-- So what does servicing a request actually mean.  As mentioned before the

-- I/O manager will be blocked or servicing a request. In reality it doesn't

-- always block till an I/O request has completed.  In cases where we have event

-- timers, we block till the next timer's timeout.  This allows us to also

-- service timers in the same loop.  The side effect of this is that we will

-- exit the I/O wait sometimes without any completions.  Not really a problem

-- but it's an important design decision.

--

-- Every time we wait, we give a pre-allocated buffer of `n`

-- `OVERLAPPED_ENTRIES` to the OS.  This means that in a single call we can

-- service up to `n` I/O requests at a time.  The size of `n` is not fixed,

-- anytime we dequeue `n` I/O requests in a single operation we double the

-- buffer size, allowing the I/O manager to be able to scale up depending

-- on the workload.  This buffer is kept alive throughout the lifetime of the

-- program and is never freed until the I/O manager is shutting down.

--

-- One very important property of the I/O subsystem is that each I/O request

-- now requires an `OVERLAPPED` structure be given to the I/O manager.  See

-- `withOverlappedEx`.  This buffer is used by the OS to fill in various state

-- information. Throughout the duration of I/O call, this buffer MUST

-- remain live.  The address is pinned by the kernel, which means that the

-- pointer must remain accessible until `GetQueuedCompletionStatusEx` returns

-- the completion associated with the handle and not just until the call to what

-- ever I/O operation was used to initialize the I/O request returns.

-- The only exception to this is when the request has hit the FAST_IO path, in

-- which case it has skipped the I/O queue and so can be freed immediately after

-- reading the results from it.

--

-- To prevent having to lookup the Haskell payload in a shared state after the

-- request completes we attach it as part of the I/O request by extending the

-- `OVERLAPPED` structure.  Instead of passing an `OVERLAPPED` structure to the

-- Windows API calls we instead pass a `HASKELL_OVERLAPPED` struct which has

-- as the first element an `OVERLAPPED structure.  This means when a request is

-- done all we need to do is cast the pointer back to `HASKELL_OVERLAPPED` and

-- read the accompanying data.  This also means we don't have a global lock and

-- so can scale much easier.

--


-- ---------------------------------------------------------------------------

-- I/O manager global thread


-- When running GHCi we still want to ensure we still only have one

-- io manager thread, even if base is loaded twice. See the docs for

-- sharedCAF for how this is done.


{-# 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
   m <- Maybe ThreadId -> IO (MVar (Maybe ThreadId))
forall a. a -> IO (MVar a)
newMVar Maybe ThreadId
forall a. Maybe a
Nothing
   sharedCAF m getOrSetGHCConcWindowsIOManagerThreadStore

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

-- ---------------------------------------------------------------------------

-- Non-threaded I/O manager callback hooks. See `ASyncWinIO.c`


foreign import ccall safe "registerIOCPHandle"
  registerIOCPHandle :: FFI.IOCP -> IO ()

foreign import ccall safe "registerAlertableWait"
-- (bool has_timeout, DWORD mssec);

  c_registerAlertableWait :: Bool -> DWORD  -> IO ()

foreign import ccall safe "getOverlappedEntries"
  getOverlappedEntries :: Ptr DWORD -> IO (Ptr OVERLAPPED_ENTRY)

foreign import ccall safe "completeSynchronousRequest"
  completeSynchronousRequest :: IO ()

------------------------------------------------------------------------

-- Manager structures


-- | Pointer offset in bytes to the location of hoData in HASKELL_OVERLAPPPED

cdOffset :: Int
cdOffset :: Int
cdOffset = Int
32
{-# LINE 312 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}

-- | Terminator symbol for IOCP request

nullReq :: Ptr CompletionData
nullReq :: Ptr CompletionData
nullReq = Ptr Int -> Ptr CompletionData
forall a b. Ptr a -> Ptr b
castPtr (Ptr Int -> Ptr CompletionData) -> Ptr Int -> Ptr CompletionData
forall a b. (a -> b) -> a -> b
$ IO (Ptr Int) -> Ptr Int
forall a. IO a -> a
unsafePerformIO (IO (Ptr Int) -> Ptr Int) -> IO (Ptr Int) -> Ptr Int
forall a b. (a -> b) -> a -> b
$ Int -> IO (Ptr Int)
forall a. Storable a => a -> IO (Ptr a)
new (Int
0 :: Int)
{-# NOINLINE nullReq #-}

-- I don't expect a lot of events, so a simple linked lists should be enough.

type EventElements = [(Event, HandleData)]
data EventData = EventData { EventData -> Event
evtTopLevel :: !Event, EventData -> EventElements
evtElems :: !EventElements }

instance Monoid EventData where
  mempty :: EventData
mempty  = Event -> EventElements -> EventData
EventData Event
evtNothing []
  mappend :: EventData -> EventData -> EventData
mappend = EventData -> EventData -> EventData
forall a. Semigroup a => a -> a -> a
(<>)

instance Semigroup EventData where
  <> :: EventData -> EventData -> EventData
(<>)   = \EventData
a EventData
b -> Event -> EventElements -> EventData
EventData (EventData -> Event
evtTopLevel EventData
a Event -> Event -> Event
forall a. Semigroup a => a -> a -> a
<> EventData -> Event
evtTopLevel EventData
b)
                             (EventData -> EventElements
evtElems EventData
a EventElements -> EventElements -> EventElements
forall a. [a] -> [a] -> [a]
++ EventData -> EventElements
evtElems EventData
b)
  stimes :: forall b. Integral b => b -> EventData -> EventData
stimes = b -> EventData -> EventData
forall b a. (Integral b, Monoid a) => b -> a -> a
stimesMonoid

data IOResult a
  = IOSuccess { forall a. IOResult a -> a
ioValue :: a }
  | IOFailed  { forall a. IOResult a -> Maybe Int
ioErrCode :: Maybe Int }

-- | The state object for the I/O manager.  This structure is available for both

-- the threaded and the non-threaded RTS.

data Manager = Manager
    { Manager -> IOCP
mgrIOCP         :: {-# UNPACK #-} !FFI.IOCP
    , Manager -> Clock
mgrClock        ::                !Clock
    , Manager -> UniqueSource
mgrUniqueSource :: {-# UNPACK #-} !UniqueSource
    , Manager -> IORef TimeoutQueue
mgrTimeouts     :: {-# UNPACK #-} !(IORef TimeoutQueue)
    , Manager -> MVar (IntTable EventData)
mgrEvntHandlers :: {-# UNPACK #-}
                         !(MVar (IT.IntTable EventData))
    , Manager -> Array OVERLAPPED_ENTRY
mgrOverlappedEntries
                      :: {-#UNPACK #-} !(A.Array OVERLAPPED_ENTRY)
    , Manager -> Maybe ThreadPool
mgrThreadPool   :: Maybe ThreadPool
    }

{-# INLINE startIOManagerThread #-}
-- | Starts a new I/O manager thread.

-- For the threaded runtime it creates a pool of OS threads which stays alive

-- until they are instructed to die.

-- For the non-threaded runtime we have a single worker thread in

-- the C runtime which we force to wake up instead.

--

-- TODO: Threadpools are not yet implemented.

startIOManagerThread :: IO () -> IO ()
startIOManagerThread :: IO () -> IO ()
startIOManagerThread IO ()
loop
  | Bool -> Bool
not Bool
threadedIOMgr
  = String -> IO ()
debugIO String
"startIOManagerThread:NonThreaded" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
    IO ()
interruptSystemManager
  | Bool
otherwise = do
    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 String -> IO ()
debugIO String
"spawning worker threads.."
                      t <- IO () -> IO ThreadId
forkOS IO ()
loop
                      debugIO $ "created io-manager threads."
                      labelThread t "IOManagerThread"
                      return (Just t)
      String -> IO ()
debugIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"startIOManagerThread old=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe ThreadId -> String
forall a. Show a => a -> String
show Maybe ThreadId
old
      case Maybe ThreadId
old of
        Maybe ThreadId
Nothing -> IO (Maybe ThreadId)
create
        Just ThreadId
t  -> do
          s <- ThreadId -> IO ThreadStatus
threadStatus ThreadId
t
          case s of
            ThreadStatus
ThreadFinished -> IO (Maybe ThreadId)
create
            ThreadStatus
ThreadDied     -> IO (Maybe ThreadId)
create
            ThreadStatus
_other         -> do  IO ()
interruptSystemManager
                                  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)

requests :: MVar Word64
requests :: MVar CompletionKey
requests = IO (MVar CompletionKey) -> MVar CompletionKey
forall a. IO a -> a
unsafePerformIO (IO (MVar CompletionKey) -> MVar CompletionKey)
-> IO (MVar CompletionKey) -> MVar CompletionKey
forall a b. (a -> b) -> a -> b
$ CompletionKey -> IO (MVar CompletionKey)
forall a. a -> IO (MVar a)
newMVar CompletionKey
0

addRequest :: IO Word64
addRequest :: IO CompletionKey
addRequest = MVar CompletionKey
-> (CompletionKey -> IO (CompletionKey, CompletionKey))
-> IO CompletionKey
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar CompletionKey
requests (\CompletionKey
x -> (CompletionKey, CompletionKey) -> IO (CompletionKey, CompletionKey)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CompletionKey
x CompletionKey -> CompletionKey -> CompletionKey
forall a. Num a => a -> a -> a
+ CompletionKey
1, CompletionKey
x CompletionKey -> CompletionKey -> CompletionKey
forall a. Num a => a -> a -> a
+ CompletionKey
1))

removeRequest :: IO Word64
removeRequest :: IO CompletionKey
removeRequest = MVar CompletionKey
-> (CompletionKey -> IO (CompletionKey, CompletionKey))
-> IO CompletionKey
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar CompletionKey
requests (\CompletionKey
x -> (CompletionKey, CompletionKey) -> IO (CompletionKey, CompletionKey)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CompletionKey
x CompletionKey -> CompletionKey -> CompletionKey
forall a. Num a => a -> a -> a
- CompletionKey
1, CompletionKey
x CompletionKey -> CompletionKey -> CompletionKey
forall a. Num a => a -> a -> a
- CompletionKey
1))

outstandingRequests :: IO Word64
outstandingRequests :: IO CompletionKey
outstandingRequests = MVar CompletionKey
-> (CompletionKey -> IO CompletionKey) -> IO CompletionKey
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar CompletionKey
requests CompletionKey -> IO CompletionKey
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return

getSystemManager :: IO Manager
getSystemManager :: IO Manager
getSystemManager = MVar Manager -> IO Manager
forall a. MVar a -> IO a
readMVar MVar Manager
managerRef

-- | Mutable reference to the IO manager

managerRef :: MVar Manager
managerRef :: MVar Manager
managerRef = IO (MVar Manager) -> MVar Manager
forall a. IO a -> a
unsafePerformIO (IO (MVar Manager) -> MVar Manager)
-> IO (MVar Manager) -> MVar Manager
forall a b. (a -> b) -> a -> b
$ IO Manager
createManager IO Manager -> (Manager -> IO (MVar Manager)) -> IO (MVar Manager)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Manager -> IO (MVar Manager)
forall a. a -> IO (MVar a)
newMVar
  where
    -- | Create the I/O manager. In the Threaded I/O manager this call doesn't

    -- have any side effects, but in the Non-Threaded I/O manager the newly

    -- created IOCP handle will be registered with the RTS.  Users should never

    -- call this.

    -- It's only used to create the single global manager which is stored

    -- in an MVar.

    --

    -- NOTE: This needs to finish without making any calls to anything requiring the

    -- I/O manager otherwise we'll get into some weird synchronization issues.

    -- Essentially this means avoid using long running operations here.

    createManager :: IO Manager
    createManager :: IO Manager
createManager = do
        String -> IO ()
debugIO String
"Starting io-manager..."
        mgrIOCP         <- IO IOCP
FFI.newIOCP
        when (not threadedIOMgr) $
          registerIOCPHandle mgrIOCP
        debugIO $ "iocp: " ++ show mgrIOCP
        mgrClock             <- getClock
        mgrUniqueSource      <- newSource
        mgrTimeouts          <- newIORef Q.empty
        mgrOverlappedEntries <- A.new 64
        mgrEvntHandlers      <- newMVar =<< IT.new callbackArraySize
        let mgrThreadPool    = Maybe a
forall a. Maybe a
Nothing

        let !mgr = Manager{Maybe ThreadPool
UniqueSource
MVar (IntTable EventData)
IORef TimeoutQueue
Array OVERLAPPED_ENTRY
IOCP
Clock
forall a. Maybe a
mgrIOCP :: IOCP
mgrClock :: Clock
mgrUniqueSource :: UniqueSource
mgrTimeouts :: IORef TimeoutQueue
mgrEvntHandlers :: MVar (IntTable EventData)
mgrOverlappedEntries :: Array OVERLAPPED_ENTRY
mgrThreadPool :: Maybe ThreadPool
mgrIOCP :: IOCP
mgrClock :: Clock
mgrUniqueSource :: UniqueSource
mgrTimeouts :: IORef TimeoutQueue
mgrOverlappedEntries :: Array OVERLAPPED_ENTRY
mgrEvntHandlers :: MVar (IntTable EventData)
mgrThreadPool :: forall a. Maybe a
..}
        return mgr
{-# NOINLINE managerRef #-}

-- | Interrupts an I/O manager Wait.  This will force the I/O manager to process

-- any outstanding events and timers.  Also called when console events such as

-- ctrl+c are used to break abort an I/O request.

interruptSystemManager :: IO ()
interruptSystemManager :: IO ()
interruptSystemManager = do
  mgr <- IO Manager
getSystemManager
  debugIO "interrupt received.."
  FFI.postQueuedCompletionStatus (mgrIOCP mgr) 0 0 nullPtr

-- | The initial number of I/O requests we can service at the same time.

-- Must be power of 2.  This number is used as the starting point to scale

-- the number of concurrent requests.  It will be doubled every time we are

-- saturated.

callbackArraySize :: Int
callbackArraySize :: Int
callbackArraySize = Int
32

-----------------------------------------------------------------------

-- Time utilities


secondsToNanoSeconds :: Seconds -> Q.Prio
secondsToNanoSeconds :: Double -> CompletionKey
secondsToNanoSeconds Double
s = Double -> CompletionKey
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> CompletionKey) -> Double -> CompletionKey
forall a b. (a -> b) -> a -> b
$ Double
s Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000000000

secondsToMilliSeconds :: Seconds -> Word32
secondsToMilliSeconds :: Double -> Word32
secondsToMilliSeconds Double
s = Double -> Word32
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> Word32) -> Double -> Word32
forall a b. (a -> b) -> a -> b
$ Double
s Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000

nanoSecondsToSeconds :: Q.Prio -> Seconds
nanoSecondsToSeconds :: CompletionKey -> Double
nanoSecondsToSeconds CompletionKey
n = CompletionKey -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral CompletionKey
n Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1000000000.0

------------------------------------------------------------------------

-- Overlapped I/O


-- | Callback that starts the overlapped I/O operation.

-- It must return successfully if and only if an I/O completion has been

-- queued.  Otherwise, it must throw an exception, which 'withOverlapped'

-- will rethrow.

type StartCallback a = LPOVERLAPPED -> IO a

-- | Specialized callback type for I/O Completion Ports calls using

-- withOverlapped.

type StartIOCallback a = StartCallback (CbResult a)

-- | CallBack result type to disambiguate between the different states

-- an I/O Completion call could be in.

data CbResult a
  = CbDone (Maybe DWORD) -- ^ Request was handled immediately, no queue.

  | CbPending            -- ^ Queued and to be handled by I/O manager

  | CbIncomplete         -- ^ I/O request is incomplete but not enqueued, handle

                         --   it synchronously.

  | CbError a            -- ^ I/O request abort, return failure immediately

  | CbNone Bool          -- ^ The caller did not do any checking, the I/O

                         --   manager will perform additional checks.

    deriving Int -> CbResult a -> String -> String
[CbResult a] -> String -> String
CbResult a -> String
(Int -> CbResult a -> String -> String)
-> (CbResult a -> String)
-> ([CbResult a] -> String -> String)
-> Show (CbResult a)
forall a. Show a => Int -> CbResult a -> String -> String
forall a. Show a => [CbResult a] -> String -> String
forall a. Show a => CbResult a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall a. Show a => Int -> CbResult a -> String -> String
showsPrec :: Int -> CbResult a -> String -> String
$cshow :: forall a. Show a => CbResult a -> String
show :: CbResult a -> String
$cshowList :: forall a. Show a => [CbResult a] -> String -> String
showList :: [CbResult a] -> String -> String
Show

-- | Associate a 'HANDLE' with the current I/O manager's completion port.

-- This must be done before using the handle with 'withOverlapped'.

associateHandle' :: HANDLE -> IO ()
associateHandle' :: Ptr () -> IO ()
associateHandle' Ptr ()
hwnd
  = do mngr <- IO Manager
getSystemManager
       associateHandle mngr hwnd

-- | A handle value representing an invalid handle.

invalidHandle :: HANDLE
invalidHandle :: Ptr ()
invalidHandle = Ptr ()
iNVALID_HANDLE_VALUE

-- | Associate a 'HANDLE' with the I/O manager's completion port.  This must be

-- done before using the handle with 'withOverlapped'.

associateHandle :: Manager -> HANDLE -> IO ()
associateHandle :: Manager -> Ptr () -> IO ()
associateHandle Manager{Maybe ThreadPool
UniqueSource
MVar (IntTable EventData)
IORef TimeoutQueue
Array OVERLAPPED_ENTRY
IOCP
Clock
mgrIOCP :: Manager -> IOCP
mgrClock :: Manager -> Clock
mgrUniqueSource :: Manager -> UniqueSource
mgrTimeouts :: Manager -> IORef TimeoutQueue
mgrEvntHandlers :: Manager -> MVar (IntTable EventData)
mgrOverlappedEntries :: Manager -> Array OVERLAPPED_ENTRY
mgrThreadPool :: Manager -> Maybe ThreadPool
mgrIOCP :: IOCP
mgrClock :: Clock
mgrUniqueSource :: UniqueSource
mgrTimeouts :: IORef TimeoutQueue
mgrEvntHandlers :: MVar (IntTable EventData)
mgrOverlappedEntries :: Array OVERLAPPED_ENTRY
mgrThreadPool :: Maybe ThreadPool
..} Ptr ()
h =
    -- Don't try to if the handle is invalid.  This can happen with i.e a closed

    -- std handle.

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ptr ()
h Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
/= Ptr ()
invalidHandle) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      -- Use as completion key the file handle itself, so we can track

      -- completion

      IOCP -> Ptr () -> CompletionKey -> IO ()
FFI.associateHandleWithIOCP IOCP
mgrIOCP Ptr ()
h (WordPtr -> CompletionKey
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WordPtr -> CompletionKey) -> WordPtr -> CompletionKey
forall a b. (a -> b) -> a -> b
$ Ptr () -> WordPtr
forall a. Ptr a -> WordPtr
ptrToWordPtr Ptr ()
h)


{- Note [Why use non-waiting getOverlappedResult requests]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  When waiting for a request that is bound to be done soon
  we spin inside waitForCompletion. There are multiple reasons
  for this.

  In the non-threaded RTS we can't perform blocking calls to
  C functions without blocking the whole RTS so immediately
  a blocking call is not an option there.

  In the threaded RTS we don't use a blocking wait for different
  reasons. In particular performing a waiting request using
  getOverlappedResult uses the hEvent object embedded in the
  OVERLAPPED structure to wait for a signal.
  However we do not provide such an object as their creation
  would incur to much overhead. Making a waiting request a
  less useful operation as it doesn't guarantee that the
  operation we were waiting one finished. Only that some
  operation on the handle did.

-}

-- | Start an overlapped I/O operation, and wait for its completion.  If

-- 'withOverlapped' is interrupted by an asynchronous exception, the operation

-- will be canceled using @CancelIoEx@.

--

-- 'withOverlapped' waits for a completion to arrive before returning or

-- throwing an exception.  This means you can use functions like

-- 'GHC.Internal.Foreign.Marshal.Alloc.alloca' to allocate buffers for the operation.

withOverlappedEx :: forall a.
                    Manager
                 -> String -- ^ Handle name

                 -> HANDLE -- ^ Windows handle associated with the operation.

                 -> Bool
                 -> Word64 -- ^ Value to use for the @OVERLAPPED@

                           --   structure's Offset/OffsetHigh members.

                 -> StartIOCallback Int
                 -> CompletionCallback (IOResult a)
                 -> IO (IOResult a)
withOverlappedEx :: forall a.
Manager
-> String
-> Ptr ()
-> Bool
-> CompletionKey
-> StartIOCallback Int
-> CompletionCallback (IOResult a)
-> IO (IOResult a)
withOverlappedEx Manager
mgr String
fname Ptr ()
h Bool
async CompletionKey
offset StartIOCallback Int
startCB CompletionCallback (IOResult a)
completionCB = do
    signal <- IO (MVar (IOResult a))
forall a. IO (MVar a)
newEmptyMVar :: IO (MVar (IOResult a))
    let signalReturn a
a = MVar (IOResult a) -> IOResult a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (IOResult a)
signal (a -> IOResult a
forall a. a -> IOResult a
IOSuccess a
a)
        signalThrow Maybe Int
ex = MVar (IOResult a) -> IOResult a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (IOResult a)
signal (Maybe Int -> IOResult a
forall a. Maybe Int -> IOResult a
IOFailed Maybe Int
ex)
    mask_ $ do
      let completionCB' Word32
e Word32
b = do
            result <- CompletionCallback (IOResult a)
completionCB Word32
e Word32
b
            case result of
              IOSuccess a
val -> a -> IO ()
signalReturn a
val
              IOFailed  Maybe Int
err -> Maybe Int -> IO ()
signalThrow Maybe Int
err

      -- Note [Memory Management]

      -- ~~~~~~~~~~~~~~~~~~~~~~~~

      -- These callback data and especially the overlapped structs have to keep

      -- alive throughout the entire lifetime of the requests.   Since this

      -- function will block until done so it can call completionCB at the end

      -- we can safely use dynamic memory management here and so reduce the

      -- possibility of memory errors.

      withRequest async offset h completionCB' $ \Ptr HASKELL_OVERLAPPED
hs_lpol Ptr CompletionData
cdData -> do
        let ptr_lpol :: Ptr b
ptr_lpol = Ptr HASKELL_OVERLAPPED
hs_lpol Ptr HASKELL_OVERLAPPED -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
cdOffset
        let lpol :: Ptr b
lpol = Ptr HASKELL_OVERLAPPED -> Ptr b
forall a b. Ptr a -> Ptr b
castPtr Ptr HASKELL_OVERLAPPED
hs_lpol
        -- We need to add the payload before calling startCBResult, the reason being

        -- that the I/O routine begins immediately then.  If we don't then the request

        -- may end up lost as processCompletion will get called with a null payload.

        Ptr (Ptr CompletionData) -> Ptr CompletionData -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (Ptr CompletionData)
forall a. Ptr a
ptr_lpol Ptr CompletionData
cdData

        -- Since FILE_SKIP_COMPLETION_PORT_ON_SUCCESS can't be

        -- relied on for non-file handles we need a way to prevent

        -- us from handling a request inline and handle a completion

        -- event handled without a queued I/O operation.  Which means we

        -- can't solely rely on the number of outstanding requests but most

        -- also check intermediate status.

        reqs <- IO CompletionKey
addRequest
        debugIO $ "+1.. " ++ show reqs ++ " requests queued. | " ++ show lpol
        cdDataCheck <- peek ptr_lpol :: IO (Ptr CompletionData)
        debugIO $ "hs_lpol:" ++ show hs_lpol
                ++ " cdData:" ++ show cdData
                ++ " ptr_lpol:" ++ show ptr_lpol
                ++ " *ptr_lpol:" ++ show cdDataCheck

        startCBResult <- startCB lpol `onException`
                        (CbError `fmap` Win32.getLastError) >>= \CbResult Int
result -> do
          -- Check to see if the operation was completed on a

          -- non-overlapping handle or was completed immediately.

          -- e.g. stdio redirection or data in cache, FAST I/O.

          success <- Ptr OVERLAPPED -> IO Int32
FFI.overlappedIOStatus Ptr OVERLAPPED
forall a. Ptr a
lpol
          err     <- getLastError
          -- Determine if the caller has done any checking.  If not then check

          -- to see if the request was completed synchronously.  We have to

          -- in order to prevent deadlocks since if it has completed

          -- synchronously we've requested to not have the completion queued.

          let result' =
                case CbResult Int
result of
                  CbNone Bool
ret -- Start by checking some flags which indicates we

                             -- are done.

                             | Int32
success Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
0          -> Maybe Word32 -> CbResult Int
forall a. Maybe Word32 -> CbResult a
CbDone Maybe Word32
forall a. Maybe a
Nothing
{-# LINE 598 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}
                             | Int32
success Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== -Int32
1073741807      -> Maybe Word32 -> CbResult Int
forall a. Maybe Word32 -> CbResult a
CbDone Maybe Word32
forall a. Maybe a
Nothing
{-# LINE 599 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}
                             -- Buffer was too small.. not sure what to do, so I'll just

                             -- complete the read request

                             | Word32
err     Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
234         -> Maybe Word32 -> CbResult Int
forall a. Maybe Word32 -> CbResult a
CbDone Maybe Word32
forall a. Maybe a
Nothing
{-# LINE 602 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}
                             | Word32
err     Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0           -> Maybe Word32 -> CbResult Int
forall a. Maybe Word32 -> CbResult a
CbDone Maybe Word32
forall a. Maybe a
Nothing
{-# LINE 603 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}
                             | Word32
err     Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
997        -> CbResult Int
forall a. CbResult a
CbPending
{-# LINE 604 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}
                             | Word32
err     Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
996     -> CbResult Int
forall a. CbResult a
CbIncomplete
{-# LINE 605 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}
                             | Word32
err     Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
38        -> Maybe Word32 -> CbResult Int
forall a. Maybe Word32 -> CbResult a
CbDone Maybe Word32
forall a. Maybe a
Nothing
{-# LINE 606 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}
                             | Word32
err     Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
109       -> Maybe Word32 -> CbResult Int
forall a. Maybe Word32 -> CbResult a
CbDone Maybe Word32
forall a. Maybe a
Nothing
{-# LINE 607 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}
                             | Word32
err     Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
259     -> Maybe Word32 -> CbResult Int
forall a. Maybe Word32 -> CbResult a
CbDone Maybe Word32
forall a. Maybe a
Nothing
{-# LINE 608 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}
                             | Word32
err     Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
995 -> Maybe Word32 -> CbResult Int
forall a. Maybe Word32 -> CbResult a
CbDone Maybe Word32
forall a. Maybe a
Nothing
{-# LINE 609 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}
                             -- This is currently mapping all non-complete requests we don't know

                             -- about as an error. I wonder if this isn't too strict..

                             | Bool -> Bool
not Bool
ret                                     -> Int -> CbResult Int
forall a. a -> CbResult a
CbError (Int -> CbResult Int) -> Int -> CbResult Int
forall a b. (a -> b) -> a -> b
$ Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
err
                             -- We check success codes after checking error as

                             -- errors are much more indicative

                             | Int32
success Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
259          -> CbResult Int
forall a. CbResult a
CbPending
{-# LINE 615 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}
                             -- If not just assume we can complete.  If we can't this will

                             -- hang because we don't know how to properly deal with it.

                             -- I don't know what the best default here is...

                             | Bool
otherwise                                   -> CbResult Int
forall a. CbResult a
CbPending
                  CbResult Int
_                                                        -> CbResult Int
result
          case result' of
            CbNone    Bool
_ -> String -> IO (CbResult Int)
forall a. HasCallStack => String -> a
error String
"withOverlappedEx: CbNone shouldn't happen."
            CbResult Int
CbIncomplete -> do
               String -> IO ()
debugIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"handling incomplete request synchronously " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Ptr (), Ptr (ZonkAny 2)) -> String
forall a. Show a => a -> String
show (Ptr ()
h, Ptr (ZonkAny 2)
forall a. Ptr a
lpol)
               res <- Ptr () -> StartIOCallback Int
waitForCompletion Ptr ()
h Ptr OVERLAPPED
forall a. Ptr a
lpol
               debugIO $ "done blocking request 2: " ++ show (h, lpol) ++ " - " ++ show res
               return res
            CbResult Int
CbPending   -> do
              -- Before we enqueue check see if operation finished in the

              -- mean time, since caller may not have done this.

              -- Normally we'd have to clear lpol with 0 before this call,

              -- however the statuses we're interested in would not get to here

              -- so we can save the memset call.

              finished <- Ptr () -> Ptr OVERLAPPED -> Bool -> IO (Maybe Word32)
FFI.getOverlappedResult Ptr ()
h Ptr OVERLAPPED
forall a. Ptr a
lpol (Bool -> Bool
not Bool
async)
              lasterr <- getLastError
              debugIO $ "== " ++ show (finished)
              status <- FFI.overlappedIOStatus lpol
              debugIO $ "== >< " ++ show (status)
              -- This status indicated that we have finished early and so we

              -- won't have a request enqueued.  Handle it inline.

              let done_early = Int32
status Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
0
{-# LINE 641 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}
                               Bool -> Bool -> Bool
|| Int32
status Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== -Int32
1073741807
{-# LINE 642 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}
                               Bool -> Bool -> Bool
|| Word32 -> Bool
errorIsCompleted Word32
lasterr
              -- This status indicates that the request hasn't finished early,

              -- but it will finish shortly.  The I/O manager will not be

              -- enqueuing this either.  Also needs to be handled inline.

              -- Sadly named pipes will always return this error, so in practice

              -- we end up always handling them synchronously. There is no good

              -- documentation on this.

              let will_finish_sync = Word32
lasterr Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
996
{-# LINE 650 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}

              debugIO $ "== >*< " ++ show (finished, done_early, will_finish_sync, h, lpol, lasterr)
              case (finished, done_early, will_finish_sync) of
                (Just Word32
_, Bool
_, Bool
_) -> do
                  String -> IO ()
debugIO String
"request handled immediately (o/b), not queued."
                  CbResult Int -> IO (CbResult Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CbResult Int -> IO (CbResult Int))
-> CbResult Int -> IO (CbResult Int)
forall a b. (a -> b) -> a -> b
$ Maybe Word32 -> CbResult Int
forall a. Maybe Word32 -> CbResult a
CbDone Maybe Word32
finished
                -- Still pending

                (Maybe Word32
Nothing, Bool
_, Bool
_) -> do
                    -- If we should add back support to suspend the IO Manager thread

                    -- then we will need to make sure it's running at this point.

                    CbResult Int -> IO (CbResult Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CbResult Int
result'
            CbError Int
err' -> Maybe Int -> IO ()
signalThrow (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
err') IO () -> IO (CbResult Int) -> IO (CbResult Int)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CbResult Int -> IO (CbResult Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CbResult Int
result'
            CbDone  Maybe Word32
_   -> do
              String -> IO ()
debugIO String
"request handled immediately (o), not queued." IO () -> IO (CbResult Int) -> IO (CbResult Int)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CbResult Int -> IO (CbResult Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CbResult Int
result'

        -- If an exception was received while waiting for IO to complete

        -- we try to cancel the request here.

        let cancel SomeException
e = do
                        nerr <- IO Word32
getLastError
                        debugIO $ "## Exception occurred. Cancelling request... "
                        debugIO $ show (e :: SomeException) ++ " : " ++ show nerr
                        _ <- uninterruptibleMask_ $ FFI.cancelIoEx' h lpol
                        -- we need to wait for the cancellation before removing

                        -- the pointer.

                        debugIO $ "## Waiting for cancellation record... "
                        _ <- FFI.getOverlappedResult h lpol True
                        oldDataPtr <- I.exchangePtr ptr_lpol nullReq
                        when (oldDataPtr == cdData) $
                          do reqs1 <- removeRequest
                             debugIO $ "-1.. " ++ show reqs1 ++ " requests queued after error."
                             completionCB' (fromIntegral nerr) 0
                        when (not threadedIOMgr) $
                          do -- Run timeouts. This way if we canceled the last

                             -- IO Request and have no timer events waiting we

                             -- can go into an unbounded alertable wait.

                             delay <- runExpiredTimeouts mgr
                             registerAlertableWait delay
                        return $ IOFailed Nothing
        let runner = do String -> IO ()
debugIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ (String -> String
dbgMsg String
":: waiting ") String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" | "  String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ptr (ZonkAny 6) -> String
forall a. Show a => a -> String
show Ptr (ZonkAny 6)
forall a. Ptr a
lpol
                        res <- MVar (IOResult a) -> IO (IOResult a)
forall a. MVar a -> IO a
readMVar MVar (IOResult a)
signal IO (IOResult a)
-> (SomeException -> IO (IOResult a)) -> IO (IOResult a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` SomeException -> IO (IOResult a)
forall {a}. SomeException -> IO (IOResult a)
cancel
                        debugIO $ dbgMsg ":: signaled "
                        case res of
                          IOFailed Maybe Int
err -> String -> Word32 -> IO (IOResult a)
forall a. String -> Word32 -> IO a
FFI.throwWinErr String
fname (Word32 -> (Int -> Word32) -> Maybe Int -> Word32
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word32
0 Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Maybe Int
err)
                          IOResult a
_            -> IOResult a -> IO (IOResult a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return IOResult a
res

        -- Sometimes we shouldn't bother with the I/O manager as the call has

        -- failed or is done.

        case startCBResult of
          CbResult Int
CbPending    -> IO (IOResult a)
runner
          CbDone Maybe Word32
rdata -> do
            oldDataPtr <- Ptr (Ptr CompletionData)
-> Ptr CompletionData -> IO (Ptr CompletionData)
forall a. Ptr (Ptr a) -> Ptr a -> IO (Ptr a)
I.exchangePtr Ptr (Ptr CompletionData)
forall a. Ptr a
ptr_lpol Ptr CompletionData
nullReq
            if (oldDataPtr == cdData)
              then
                do reqs2 <- removeRequest
                   debugIO $ "-1.. " ++ show reqs2 ++ " requests queued."
                   debugIO $ dbgMsg $ ":: done " ++ show lpol ++ " - " ++ show rdata
                   bytes <- if isJust rdata
                               then return rdata
                               -- Make sure it's safe to free the OVERLAPPED buffer

                               else FFI.getOverlappedResult h lpol False
                   cdDataCheck2 <- peek ptr_lpol :: IO (Ptr CompletionData)
                   debugIO $ dbgMsg $ ":: exit *ptr_lpol: " ++ show cdDataCheck2
                   debugIO $ dbgMsg $ ":: done bytes: " ++ show bytes
                   case bytes of
                     Just Word32
res -> CompletionCallback (IOResult a)
completionCB Word32
0 Word32
res
                     Maybe Word32
Nothing  -> do err <- Ptr OVERLAPPED -> IO Int32
FFI.overlappedIOStatus Ptr OVERLAPPED
forall a. Ptr a
lpol
                                    numBytes <- FFI.overlappedIONumBytes lpol
                                    -- TODO: Remap between STATUS_ and ERROR_ instead

                                    -- of re-interpret here. But for now, don't care.

                                    let err' = Int32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
err
                                    debugIO $ dbgMsg $ ":: done callback: " ++ show err' ++ " - " ++ show numBytes
                                    completionCB err' (fromIntegral numBytes)
              else readMVar signal
          CbError Int
err  -> do
            reqs3 <- IO CompletionKey
removeRequest
            debugIO $ "-1.. " ++ show reqs3 ++ " requests queued."
            let err' = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
err
            completionCB err' 0
          CbResult Int
_            -> do
            String -> IO (IOResult a)
forall a. HasCallStack => String -> a
error String
"unexpected case in `startCBResult'"
      where dbgMsg :: String -> String
dbgMsg String
s = String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ptr () -> String
forall a. Show a => a -> String
show Ptr ()
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ CompletionKey -> String
forall a. Show a => a -> String
show CompletionKey
offset String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
            -- Wait for .25ms (threaded) and 1ms (non-threaded)

            -- Yields in the threaded case allowing other work.

            -- Blocks all haskell execution in the non-threaded case.

            -- We might want to reconsider the non-threaded handling

            -- at some point.

            doShortWait :: IO ()
            doShortWait :: IO ()
doShortWait
                | Bool
threadedIOMgr = do
                    -- Uses an inline definition of threadDelay to prevent an import

                    -- cycle.

                    let usecs :: Int
usecs = Int
250 -- 0.25ms

                    m <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
                    reg <- registerTimeout mgr usecs $
                                putMVar m () >> return ()
                    readMVar m `onException` unregisterTimeout mgr reg
                | Bool
otherwise = Int -> IO ()
sleepBlock Int
1 -- 1 ms

            waitForCompletion :: HANDLE -> Ptr FFI.OVERLAPPED -> IO (CbResult Int)
            waitForCompletion :: Ptr () -> StartIOCallback Int
waitForCompletion Ptr ()
fhndl Ptr OVERLAPPED
lpol = do
              -- Wait for the request to finish as it was running before and

              -- The I/O manager won't enqueue it due to our optimizations to

              -- prevent context switches in such cases.

              -- In the non-threaded case we must use a non-waiting query here

              -- otherwise the RTS will lock up until we get a result back.

              -- In the threaded case it can be beneficial to spin on the haskell

              -- side versus

              -- See also Note [Why use non-waiting getOverlappedResult requests]

              res <- Ptr () -> Ptr OVERLAPPED -> Bool -> IO (Maybe Word32)
FFI.getOverlappedResult Ptr ()
fhndl Ptr OVERLAPPED
lpol Bool
False
              status <- FFI.overlappedIOStatus lpol
              case res of
                Maybe Word32
Nothing | Int32
status Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== -Int32
1073741807
{-# LINE 761 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}
                        -> do
                              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
threadedIOMgr) IO ()
completeSynchronousRequest
                              CbResult Int -> IO (CbResult Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CbResult Int -> IO (CbResult Int))
-> CbResult Int -> IO (CbResult Int)
forall a b. (a -> b) -> a -> b
$ Maybe Word32 -> CbResult Int
forall a. Maybe Word32 -> CbResult a
CbDone Maybe Word32
res
                        | Bool
otherwise ->
                  do lasterr <- IO Word32
getLastError
                     let done = Word32 -> Bool
errorIsCompleted Word32
lasterr
                     -- debugIO $ ":: loop - " ++ show lasterr ++ " :" ++ show done

                     -- We will complete quite soon, in the threaded RTS we

                     -- probably don't really want to wait for it while we could

                     -- have done something else.  In particular this is because

                     -- of sockets which make take slightly longer.

                     -- There's a trade-off.  Using the timer would allow it do

                     -- to continue running other Haskell threads, but also

                     -- means it may take longer to complete the wait.

                     unless done doShortWait
                     if done
                        then do when (not threadedIOMgr)
                                  completeSynchronousRequest
                                return $ CbDone Nothing
                        else waitForCompletion fhndl lpol
                Just Word32
_ -> do
                   Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
threadedIOMgr) IO ()
completeSynchronousRequest
                   CbResult Int -> IO (CbResult Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CbResult Int -> IO (CbResult Int))
-> CbResult Int -> IO (CbResult Int)
forall a b. (a -> b) -> a -> b
$ Maybe Word32 -> CbResult Int
forall a. Maybe Word32 -> CbResult a
CbDone Maybe Word32
res
            unless :: Bool -> IO () -> IO ()
            unless :: Bool -> IO () -> IO ()
unless Bool
p IO ()
a = if Bool
p then IO ()
a else () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Safe version of function of withOverlappedEx that assumes your handle is

-- set up for asynchronous access.

withOverlapped :: String
               -> HANDLE
               -> Word64 -- ^ Value to use for the @OVERLAPPED@

                         --   structure's Offset/OffsetHigh members.

               -> StartIOCallback Int
               -> CompletionCallback (IOResult a)
               -> IO (IOResult a)
withOverlapped :: forall a.
String
-> Ptr ()
-> CompletionKey
-> StartIOCallback Int
-> CompletionCallback (IOResult a)
-> IO (IOResult a)
withOverlapped String
fname Ptr ()
h CompletionKey
offset StartIOCallback Int
startCB CompletionCallback (IOResult a)
completionCB = do
  mngr <- IO Manager
getSystemManager
  withOverlappedEx mngr fname h True offset startCB completionCB

------------------------------------------------------------------------

-- Helper to check if an error code implies an operation has completed.


errorIsCompleted :: ErrCode -> Bool
errorIsCompleted :: Word32 -> Bool
errorIsCompleted Word32
lasterr =
       Word32
lasterr Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
38
{-# LINE 806 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}
    || lasterr == 0
{-# LINE 807 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}
    || lasterr == 109
{-# LINE 808 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}
    || lasterr == 259
{-# LINE 809 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}
    || lasterr == 995
{-# LINE 810 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}

------------------------------------------------------------------------

-- I/O Utilities


-- | Process an IOResult and throw an exception back to the user if the action

-- has failed, or return the result.

withException :: String -> IO (IOResult a) -> IO a
withException :: forall a. String -> IO (IOResult a) -> IO a
withException String
name IO (IOResult a)
fn
 = do res <- IO (IOResult a)
fn
      case res of
       IOSuccess a
a         -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
       IOFailed (Just Int
err) -> String -> Word32 -> IO a
forall a. String -> Word32 -> IO a
FFI.throwWinErr String
name (Word32 -> IO a) -> Word32 -> IO a
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
err
       IOFailed Maybe Int
Nothing    -> String -> Word32 -> IO a
forall a. String -> Word32 -> IO a
FFI.throwWinErr String
name Word32
0

-- | Signal that the I/O action was successful.

ioSuccess :: a -> IO (IOResult a)
ioSuccess :: forall a. a -> IO (IOResult a)
ioSuccess = IOResult a -> IO (IOResult a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IOResult a -> IO (IOResult a))
-> (a -> IOResult a) -> a -> IO (IOResult a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IOResult a
forall a. a -> IOResult a
IOSuccess

-- | Signal that the I/O action has failed with the given reason.

ioFailed :: Integral a => a -> IO (IOResult a)
ioFailed :: forall a. Integral a => a -> IO (IOResult a)
ioFailed = IOResult a -> IO (IOResult a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IOResult a -> IO (IOResult a))
-> (a -> IOResult a) -> a -> IO (IOResult a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> IOResult a
forall a. Maybe Int -> IOResult a
IOFailed (Maybe Int -> IOResult a) -> (a -> Maybe Int) -> a -> IOResult a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (a -> Int) -> a -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | Signal that the I/O action has failed with the given reason.

-- Polymorphic in successful result type.

ioFailedAny :: Integral a => a -> IO (IOResult b)
ioFailedAny :: forall a b. Integral a => a -> IO (IOResult b)
ioFailedAny = IOResult b -> IO (IOResult b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IOResult b -> IO (IOResult b))
-> (a -> IOResult b) -> a -> IO (IOResult b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> IOResult b
forall a. Maybe Int -> IOResult a
IOFailed (Maybe Int -> IOResult b) -> (a -> Maybe Int) -> a -> IOResult b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (a -> Int) -> a -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

------------------------------------------------------------------------

-- Timeouts


-- | Convert uS(Int) to nS(Word64/Q.Prio) capping at maxBound

expirationTime :: Clock -> Int -> IO Q.Prio
expirationTime :: Clock -> Int -> IO CompletionKey
expirationTime Clock
mgr Int
us = do
    now <- Clock -> IO Double
getTime Clock
mgr :: IO Seconds -- Double

    let now_ns = Double -> CompletionKey
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> CompletionKey) -> Double -> CompletionKey
forall a b. (a -> b) -> a -> b
$ Double
now Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000 :: Word64
    let expTime
          -- Currently we treat overflows by clamping to maxBound. If humanity

          -- still exists in 2500 CE we will ned to be a bit more careful here.

          -- See #15158.

          | (CompletionKey
forall a. Bounded a => a
maxBound CompletionKey -> CompletionKey -> CompletionKey
forall a. Num a => a -> a -> a
- CompletionKey
now_ns) CompletionKey -> CompletionKey -> CompletionKey
forall a. Integral a => a -> a -> a
`quot` CompletionKey
1000 CompletionKey -> CompletionKey -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> CompletionKey
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
us  = CompletionKey
forall a. Bounded a => a
maxBound :: Q.Prio
          | Bool
otherwise                                          = CompletionKey
now_ns CompletionKey -> CompletionKey -> CompletionKey
forall a. Num a => a -> a -> a
+ CompletionKey
ns
          where ns :: CompletionKey
ns = CompletionKey
1000 CompletionKey -> CompletionKey -> CompletionKey
forall a. Num a => a -> a -> a
* Int -> CompletionKey
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
us
    return expTime

-- | Register an action to be performed in the given number of seconds.  The

-- returned 'TimeoutKey' can be used to later un-register or update the timeout.

-- The timeout is automatically unregistered when it fires.

--

-- The 'TimeoutCallback' will not be called more than once.

--

-- Be careful not to exceed @maxBound :: Int@, which on 32-bit machines is only

-- 2147483647 μs, less than 36 minutes.

--

{-# NOINLINE registerTimeout #-}
registerTimeout :: Manager -> Int -> TimeoutCallback -> IO TimeoutKey
registerTimeout :: Manager -> Int -> IO () -> IO TimeoutKey
registerTimeout mgr :: Manager
mgr@Manager{Maybe ThreadPool
UniqueSource
MVar (IntTable EventData)
IORef TimeoutQueue
Array OVERLAPPED_ENTRY
IOCP
Clock
mgrIOCP :: Manager -> IOCP
mgrClock :: Manager -> Clock
mgrUniqueSource :: Manager -> UniqueSource
mgrTimeouts :: Manager -> IORef TimeoutQueue
mgrEvntHandlers :: Manager -> MVar (IntTable EventData)
mgrOverlappedEntries :: Manager -> Array OVERLAPPED_ENTRY
mgrThreadPool :: Manager -> Maybe ThreadPool
mgrIOCP :: IOCP
mgrClock :: Clock
mgrUniqueSource :: UniqueSource
mgrTimeouts :: IORef TimeoutQueue
mgrEvntHandlers :: MVar (IntTable EventData)
mgrOverlappedEntries :: Array OVERLAPPED_ENTRY
mgrThreadPool :: Maybe ThreadPool
..} Int
uSrelTime IO ()
cb = do
    key <- UniqueSource -> IO Unique
newUnique UniqueSource
mgrUniqueSource
    if uSrelTime <= 0 then cb
    else do
      !expTime <- expirationTime mgrClock uSrelTime :: IO Q.Prio
      editTimeouts mgr (Q.unsafeInsertNew key expTime cb)
    return $ TK key

-- | Update an active timeout to fire in the given number of seconds (from the

-- time 'updateTimeout' is called), instead of when it was going to fire.

-- This has no effect if the timeout has already fired.

--

-- Be careful not to exceed @maxBound :: Int@, which on 32-bit machines is only

-- 2147483647 μs, less than 36 minutes.

--

updateTimeout :: Manager -> TimeoutKey -> Seconds -> IO ()
updateTimeout :: Manager -> TimeoutKey -> Double -> IO ()
updateTimeout Manager
mgr (TK Unique
key) Double
relTime = do
    now <- Clock -> IO Double
getTime (Manager -> Clock
mgrClock Manager
mgr)
    let !expTime = Double -> CompletionKey
secondsToNanoSeconds (Double -> CompletionKey) -> Double -> CompletionKey
forall a b. (a -> b) -> a -> b
$ Double
now Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
relTime
    -- Note: editTimeouts unconditionally wakes the IO Manager

    --       but that is not required if the new time is after

    --       the current time.

    editTimeouts mgr (Q.adjust (const expTime) key)

-- | Unregister an active timeout.  This is a harmless no-op if the timeout is

-- already unregistered or has already fired.

--

-- Warning: the timeout callback may fire even after

-- 'unregisterTimeout' completes.

unregisterTimeout :: Manager -> TimeoutKey -> IO ()
unregisterTimeout :: Manager -> TimeoutKey -> IO ()
unregisterTimeout Manager
mgr (TK Unique
key) = do
    Manager -> TimeoutEdit -> IO ()
editTimeouts Manager
mgr (Unique -> TimeoutEdit
forall v. Unique -> IntPSQ v -> IntPSQ v
Q.delete Unique
key)

-- | Modify an existing timeout.  This isn't thread safe and so if the time to

-- elapse the timer was close it may fire anyway.

editTimeouts :: Manager -> TimeoutEdit -> IO ()
editTimeouts :: Manager -> TimeoutEdit -> IO ()
editTimeouts Manager
mgr TimeoutEdit
g = do
  IORef TimeoutQueue -> (TimeoutQueue -> (TimeoutQueue, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (Manager -> IORef TimeoutQueue
mgrTimeouts Manager
mgr) ((TimeoutQueue -> (TimeoutQueue, ())) -> IO ())
-> (TimeoutQueue -> (TimeoutQueue, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TimeoutQueue
tq -> (TimeoutEdit
g TimeoutQueue
tq, ())
  IO ()
interruptSystemManager

------------------------------------------------------------------------

-- I/O manager loop


-- | Call all expired timeouts, and return how much time until the next

-- | expiration.

runExpiredTimeouts :: Manager -> IO (Maybe Seconds)
runExpiredTimeouts :: Manager -> IO (Maybe Double)
runExpiredTimeouts Manager{Maybe ThreadPool
UniqueSource
MVar (IntTable EventData)
IORef TimeoutQueue
Array OVERLAPPED_ENTRY
IOCP
Clock
mgrIOCP :: Manager -> IOCP
mgrClock :: Manager -> Clock
mgrUniqueSource :: Manager -> UniqueSource
mgrTimeouts :: Manager -> IORef TimeoutQueue
mgrEvntHandlers :: Manager -> MVar (IntTable EventData)
mgrOverlappedEntries :: Manager -> Array OVERLAPPED_ENTRY
mgrThreadPool :: Manager -> Maybe ThreadPool
mgrIOCP :: IOCP
mgrClock :: Clock
mgrUniqueSource :: UniqueSource
mgrTimeouts :: IORef TimeoutQueue
mgrEvntHandlers :: MVar (IntTable EventData)
mgrOverlappedEntries :: Array OVERLAPPED_ENTRY
mgrThreadPool :: Maybe ThreadPool
..} = do
    now <- Clock -> IO Double
getTime Clock
mgrClock
    (expired, delay) <- atomicModifyIORef' mgrTimeouts (mkTimeout now)
    -- Execute timeout callbacks.

    mapM_ Q.value expired
    when (not threadedIOMgr && not (null expired))
      completeSynchronousRequest
    debugIO $ "expired calls: " ++ show (length expired)
    return delay
      where
        mkTimeout :: Seconds -> TimeoutQueue ->
                     (TimeoutQueue, ([Q.Elem TimeoutCallback], Maybe Seconds))
        mkTimeout :: Double
-> TimeoutQueue -> (TimeoutQueue, ([Elem (IO ())], Maybe Double))
mkTimeout Double
now TimeoutQueue
tq =
            let (TimeoutQueue
tq', ([Elem (IO ())]
expired, Maybe CompletionKey
sec)) = CompletionKey
-> TimeoutQueue
-> (TimeoutQueue, ([Elem (IO ())], Maybe CompletionKey))
mkTimeout' (Double -> CompletionKey
secondsToNanoSeconds Double
now) TimeoutQueue
tq
            in (TimeoutQueue
tq', ([Elem (IO ())]
expired, (CompletionKey -> Double) -> Maybe CompletionKey -> Maybe Double
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CompletionKey -> Double
nanoSecondsToSeconds Maybe CompletionKey
sec))
        mkTimeout' :: Q.Prio -> TimeoutQueue ->
                     (TimeoutQueue, ([Q.Elem TimeoutCallback], Maybe Q.Prio))
        mkTimeout' :: CompletionKey
-> TimeoutQueue
-> (TimeoutQueue, ([Elem (IO ())], Maybe CompletionKey))
mkTimeout' CompletionKey
now TimeoutQueue
tq =
           -- Remove timeouts with expiration <= now.

           let ([Elem (IO ())]
expired, TimeoutQueue
tq') = CompletionKey -> TimeoutQueue -> ([Elem (IO ())], TimeoutQueue)
forall v. CompletionKey -> IntPSQ v -> ([Elem v], IntPSQ v)
Q.atMost CompletionKey
now TimeoutQueue
tq in
           -- See how soon the next timeout expires.

           case Elem (IO ()) -> CompletionKey
forall a. Elem a -> CompletionKey
Q.prio (Elem (IO ()) -> CompletionKey)
-> Maybe (Elem (IO ())) -> Maybe CompletionKey
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` TimeoutQueue -> Maybe (Elem (IO ()))
forall v. IntPSQ v -> Maybe (Elem v)
Q.findMin TimeoutQueue
tq' of
            Maybe CompletionKey
Nothing ->
                (TimeoutQueue
tq', ([Elem (IO ())]
expired, Maybe CompletionKey
forall a. Maybe a
Nothing))
            Just CompletionKey
t ->
                -- This value will always be positive since the call

                -- to 'atMost' above removed any timeouts <= 'now'

                let !t' :: CompletionKey
t' = CompletionKey
t CompletionKey -> CompletionKey -> CompletionKey
forall a. Num a => a -> a -> a
- CompletionKey
now
                in (TimeoutQueue
tq', ([Elem (IO ())]
expired, CompletionKey -> Maybe CompletionKey
forall a. a -> Maybe a
Just CompletionKey
t'))

-- | Return the delay argument to pass to GetQueuedCompletionStatus.

--   Return value is in ms

fromTimeout :: Maybe Seconds -> Word32
fromTimeout :: Maybe Double -> Word32
fromTimeout Maybe Double
Nothing                 = Word32
120000
fromTimeout (Just Double
sec) | Double
sec Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
120  = Word32
120000
                       | Double
sec Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0    = Double -> Word32
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double
sec Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000)
                       | Bool
otherwise  = Word32
0

-- | Perform one full evaluation step of the I/O manager's service loop.

-- This means process timeouts and completed completions and calculate the time

-- for the next timeout.

--

-- The I/O manager is then notified of how long it should block again based on

-- the queued I/O requests and timers.  If the I/O manager was given a command

-- to block, shutdown or suspend than that request is honored at the end of the

-- loop.

--

-- This function can be safely executed multiple times in parallel and is only

-- used by the threaded manager.

step :: Bool -> Manager -> IO (Bool, Maybe Seconds)
step :: Bool -> Manager -> IO (Bool, Maybe Double)
step Bool
maxDelay mgr :: Manager
mgr@Manager{Maybe ThreadPool
UniqueSource
MVar (IntTable EventData)
IORef TimeoutQueue
Array OVERLAPPED_ENTRY
IOCP
Clock
mgrIOCP :: Manager -> IOCP
mgrClock :: Manager -> Clock
mgrUniqueSource :: Manager -> UniqueSource
mgrTimeouts :: Manager -> IORef TimeoutQueue
mgrEvntHandlers :: Manager -> MVar (IntTable EventData)
mgrOverlappedEntries :: Manager -> Array OVERLAPPED_ENTRY
mgrThreadPool :: Manager -> Maybe ThreadPool
mgrIOCP :: IOCP
mgrClock :: Clock
mgrUniqueSource :: UniqueSource
mgrTimeouts :: IORef TimeoutQueue
mgrEvntHandlers :: MVar (IntTable EventData)
mgrOverlappedEntries :: Array OVERLAPPED_ENTRY
mgrThreadPool :: Maybe ThreadPool
..} = do
    -- Determine how long to wait the next time we block in an alertable state.

    delay <- Manager -> IO (Maybe Double)
runExpiredTimeouts Manager
mgr
    let !timer = if Bool
maxDelay Bool -> Bool -> Bool
&& Maybe Double
delay Maybe Double -> Maybe Double -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Double
forall a. Maybe a
Nothing
                    then Word32
4294967295
{-# LINE 966 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}
                    else Maybe Double -> Word32
fromTimeout Maybe Double
delay
    debugIO $ "next timer: " ++ show timer -- todo: print as hex

    if isJust delay
        then debugIO $ "I/O manager waiting: delay=" ++ show delay
        else debugIO $ "I/O manager pausing: maxDelay=" ++ show maxDelay

    -- Inform the threadpool that a thread is now

    -- entering a kernel mode wait and thus is ready for new work.

    notifyWaiting mgrThreadPool

    -- To quote Matt Godbolts:

    -- There are some unusual edge cases you need to deal with. The

    -- GetQueuedCompletionStatus function blocks a thread until there's

    -- work for it to do. Based on the return value, the number of bytes

    -- and the overlapped structure, there’s a lot of possible "reasons"

    -- for the function to have returned. Deciphering all the possible

    -- cases:

    --

    -- ------------------------------------------------------------------------

    -- Ret value | OVERLAPPED | # of bytes | Description

    -- ------------------------------------------------------------------------

    -- zero      | NULL       | n/a        | Call to GetQueuedCompletionStatus

    --   failed, and no data was dequeued from the IO port. This usually

    --   indicates an error in the parameters to GetQueuedCompletionStatus.

    --

    -- zero      | non-NULL   | n/a        | Call to GetQueuedCompletionStatus

    --   failed, but data was read or written. The thread must deal with the

    --   data (possibly freeing any associated buffers), but there is an error

    --   condition on the underlying HANDLE. Usually seen when the other end of

    --   a network connection has been forcibly closed but there's still data in

    --   the send or receive queue.

    --

    -- non-zero  | NULL       | n/a        | This condition doesn't happen due

    --   to IO requests, but is useful to use in combination with

    --   PostQueuedCompletionStatus as a way of indicating to threads that they

    --   should terminate.

    --

    -- non-zero  | non-NULL   | zero       | End of file for a file HANDLE, or

    --   the connection has been gracefully closed (for network connections).

    --   The OVERLAPPED buffer has still been used; and must be deallocated if

    --   necessary.

    --

    -- non-zero  | non-NULL   | non-zero   | "num bytes" of data have been

    --    transferred into the block pointed by the OVERLAPPED structure. The

    --    direction of the transfer is dependant on the call made to the IO

    --    port, it's up to the user to remember if it was a read or a write

    --    (usually by stashing extra data in the OVERLAPPED structure). The

    --    thread must deallocate the structure as necessary.

    --

    -- The getQueuedCompletionStatusEx call will remove entries queued by the OS

    -- and returns the finished ones in mgrOverlappedEntries and the number of

    -- entries removed.

    n <- FFI.getQueuedCompletionStatusEx mgrIOCP mgrOverlappedEntries timer
    debugIO "WinIORunning"
    -- If threaded this call informs the threadpool manager that a thread is

    -- busy.  If all threads are busy and we have not reached the maximum amount

    -- of allowed threads then the threadpool manager will spawn a new thread to

    -- allow us to scale under load.

    notifyRunning mgrThreadPool
    processCompletion mgr n delay

-- | Process the results at the end of an evaluation loop.  This function will

-- read all the completions, unblock up all the Haskell threads, clean up the book

-- keeping of the I/O manager.

-- It returns whether there is outstanding work (request or timer) to be

-- done and how long it expects to have to wait till it can take action again.

--

-- Note that this method can do less work than there are entries in the

-- completion table.  This is because some completion entries may have been

-- created due to calls to interruptIOManager which will enqueue a faux

-- completion.

--

-- NOTE: In Threaded mode things get a bit complicated the operation may have

-- been completed even before we even got around to put the request in the

-- waiting callback table.  These events are handled by having a separate queue

-- for orphaned callback instances that the calling thread is supposed to check

-- before adding something to the work queue.

--

-- Thread safety: This function atomically replaces outstanding events with

-- a pointer to nullReq. This means it's safe (but potentially wasteful) to

-- have two concurrent or parallel invocations on the same array.

processCompletion :: Manager -> Int -> Maybe Seconds -> IO (Bool, Maybe Seconds)
processCompletion :: Manager -> Int -> Maybe Double -> IO (Bool, Maybe Double)
processCompletion Manager{Maybe ThreadPool
UniqueSource
MVar (IntTable EventData)
IORef TimeoutQueue
Array OVERLAPPED_ENTRY
IOCP
Clock
mgrIOCP :: Manager -> IOCP
mgrClock :: Manager -> Clock
mgrUniqueSource :: Manager -> UniqueSource
mgrTimeouts :: Manager -> IORef TimeoutQueue
mgrEvntHandlers :: Manager -> MVar (IntTable EventData)
mgrOverlappedEntries :: Manager -> Array OVERLAPPED_ENTRY
mgrThreadPool :: Manager -> Maybe ThreadPool
mgrIOCP :: IOCP
mgrClock :: Clock
mgrUniqueSource :: UniqueSource
mgrTimeouts :: IORef TimeoutQueue
mgrEvntHandlers :: MVar (IntTable EventData)
mgrOverlappedEntries :: Array OVERLAPPED_ENTRY
mgrThreadPool :: Maybe ThreadPool
..} Int
n Maybe Double
delay = do
    -- If some completions are done, we need to process them and call their

    -- callbacks.  We then remove the callbacks from the bookkeeping and resize

    -- the array if required.

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..(Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
idx -> do
        oe <- Array OVERLAPPED_ENTRY -> Int -> IO OVERLAPPED_ENTRY
forall a. Storable a => Array a -> Int -> IO a
A.unsafeRead Array OVERLAPPED_ENTRY
mgrOverlappedEntries Int
idx :: IO OVERLAPPED_ENTRY
        let lpol     = OVERLAPPED_ENTRY -> Ptr OVERLAPPED
lpOverlapped OVERLAPPED_ENTRY
oe
        when (lpol /= nullPtr) $ do
          let hs_lpol  = Ptr OVERLAPPED -> Ptr HASKELL_OVERLAPPED
forall a b. Ptr a -> Ptr b
castPtr Ptr OVERLAPPED
lpol :: Ptr FFI.HASKELL_OVERLAPPED
          let ptr_lpol = Ptr (ZonkAny 7) -> Ptr (Ptr CompletionData)
forall a b. Ptr a -> Ptr b
castPtr (Ptr HASKELL_OVERLAPPED
hs_lpol Ptr HASKELL_OVERLAPPED -> Int -> Ptr (ZonkAny 7)
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
cdOffset) :: Ptr (Ptr CompletionData)
          cdDataCheck <- peek ptr_lpol
          oldDataPtr <- I.exchangePtr ptr_lpol nullReq :: IO (Ptr CompletionData)
          debugIO $ " $ checking " ++ show lpol
                    ++ " -en ptr_lpol: " ++ show ptr_lpol
                    ++ " offset: " ++ show cdOffset
                    ++ " cdData: " ++ show cdDataCheck
                    ++ " at idx " ++ show idx
          ptrd <- peek ptr_lpol
          debugIO $ ":: nullReq " ++ show nullReq
          debugIO $ ":: oldDataPtr " ++ show oldDataPtr
          debugIO $ ":: oldDataPtr (ptr)" ++ show ptrd
          -- A nullPtr indicates that we received a request which we shouldn't

          -- have. Essentially the field is 0 initialized and a nullPtr means

          -- it wasn't given a payload.

          -- A nullReq means that something else already handled the request,

          -- this can happen if for instance the request was cancelled.

          -- The former is an error while the latter is OK.  For now we treat

          -- them both as the same, but external tools such as API monitor are

          -- used to distinguish between the two when doing API tracing.

          when (oldDataPtr /= nullPtr && oldDataPtr /= castPtr nullReq) $
            do debugIO $ "exchanged: " ++ show oldDataPtr
               payload <- peek oldDataPtr :: IO CompletionData
               cb <- deRefStablePtr (cdCallback payload)
               reqs <- removeRequest
               debugIO $ "-1.. " ++ show reqs ++ " requests queued."
               status <- FFI.overlappedIOStatus (lpOverlapped oe)
               -- TODO: Remap between STATUS_ and ERROR_ instead

               -- of re-interpret here. But for now, don't care.

               let status' = Int32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
status
               -- We no longer explicitly free the memory, this is because we

               -- now require the callback to free the memory since the

               -- callback allocated it.  This allows us to simplify memory

               -- management and reduce bugs.  See Note [Memory Management].

               let bytes = OVERLAPPED_ENTRY -> Word32
dwNumberOfBytesTransferred OVERLAPPED_ENTRY
oe
               debugIO $ "?: status " ++ show status' ++ " - " ++ show bytes ++ " bytes return."
               cb status' bytes

      -- clear the array so we don't erroneously interpret the output, in

      -- certain circumstances like lockFileEx the code could return 1 entry

      -- removed but the file data not been filled in.

      -- TODO: Maybe not needed..

      Array OVERLAPPED_ENTRY -> IO ()
forall a. Array a -> IO ()
A.clear Array OVERLAPPED_ENTRY
mgrOverlappedEntries

      -- Check to see if we received the maximum amount of entries we could

      -- this likely indicates a high number of I/O requests have been queued.

      -- In which case we should process more at a time.

      cap <- Array OVERLAPPED_ENTRY -> IO Int
forall a. Array a -> IO Int
A.capacity Array OVERLAPPED_ENTRY
mgrOverlappedEntries
      when (cap == n) $ A.ensureCapacity mgrOverlappedEntries (2*cap)

    -- Keep running if we still have some work queued or

    -- if we have a pending delay.

    reqs <- IO CompletionKey
outstandingRequests
    debugIO $ "outstanding requests: " ++ show reqs
    let more = CompletionKey
reqs CompletionKey -> CompletionKey -> Bool
forall a. Ord a => a -> a -> Bool
> CompletionKey
0
    debugIO $ "has more: " ++ show more ++ " - removed: " ++  show n
    return (more || (isJust delay && threadedIOMgr), delay)

-- | Entry point for the non-threaded I/O manager to be able to process

-- completed completions.  It is mostly a wrapper around processCompletion

-- and invoked by the C thread via the scheduler.

processRemoteCompletion :: IO ()
processRemoteCompletion :: IO ()
processRemoteCompletion = do

{-# LINE 1125 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}
  (Ptr Word32 -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Word32 -> IO ()) -> IO ()) -> (Ptr Word32 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word32
ptr_n -> do
    String -> IO ()
debugIO String
"processRemoteCompletion :: start ()"
    -- First figure out how much work we have to do.

    entries <- Ptr Word32 -> IO (Ptr OVERLAPPED_ENTRY)
getOverlappedEntries Ptr Word32
ptr_n
    n <- fromIntegral `fmap` peek ptr_n
    -- This call will unmarshal data from the C buffer but pointers inside of

    -- this have not been read yet.

    _ <- peekArray n entries
    mngr <- getSystemManager
    let arr = Manager -> Array OVERLAPPED_ENTRY
mgrOverlappedEntries Manager
mngr
    A.unsafeCopyFromBuffer arr entries n

    -- Process timeouts

    delay <- runExpiredTimeouts mngr :: IO (Maybe Seconds)

    -- Process available completions

    _ <- processCompletion mngr n delay

    -- Update and potentially wake up IO Manager

    -- This call will unblock the non-threaded I/O manager.  After this it is no

    -- longer safe to use `entries` nor `completed` as they can now be modified

    -- by the C thread.

    registerAlertableWait delay

    debugIO "processRemoteCompletion :: done ()"
    return ()

registerAlertableWait :: Maybe Seconds  -> IO ()
registerAlertableWait :: Maybe Double -> IO ()
registerAlertableWait Maybe Double
Nothing =
  Bool -> Word32 -> IO ()
c_registerAlertableWait Bool
False Word32
0
registerAlertableWait (Just Double
delay) =
  Bool -> Word32 -> IO ()
c_registerAlertableWait Bool
True (Double -> Word32
secondsToMilliSeconds Double
delay)

-- | Event loop for the Threaded I/O manager.  The one for the non-threaded

-- I/O manager is in AsyncWinIO.c in the rts.

io_mngr_loop :: HANDLE -> Manager -> IO ()
io_mngr_loop :: Ptr () -> Manager -> IO ()
io_mngr_loop Ptr ()
_event Manager
_mgr
  | Bool -> Bool
not Bool
threadedIOMgr
  = do  String -> IO ()
debugIO String
"io_mngr_loop:no-op:called in non-threaded case"
        () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
io_mngr_loop Ptr ()
_event Manager
mgr = Bool -> IO ()
go Bool
False
    where
      go :: Bool -> IO ()
go Bool
maxDelay =
          do String -> IO ()
debugIO String
"io_mngr_loop:WinIORunning"
             -- Step will process IO events, or block if none are outstanding.

             (more, delay) <- Bool -> Manager -> IO (Bool, Maybe Double)
step Bool
maxDelay Manager
mgr
             let !use_max_delay = Bool -> Bool
not (Maybe Double -> Bool
forall a. Maybe a -> Bool
isJust Maybe Double
delay Bool -> Bool -> Bool
|| Bool
more)
             debugIO "I/O manager stepping."
             event_id <- c_readIOManagerEvent
             exit <-
               case event_id of
                 Word32
_ | Word32
event_id Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
io_MANAGER_WAKEUP -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                 Word32
_ | Word32
event_id Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
io_MANAGER_DIE    -> IO ()
c_ioManagerFinished IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                 Word32
0 -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False -- spurious wakeup

                 Word32
_ -> do String -> IO ()
debugIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"handling console event: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show (Word32
event_id Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
1)
                         Word32 -> IO ()
start_console_handler (Word32
event_id Word32 -> Int -> Word32
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

             -- If we have no more work to do, or something from the outside

             -- told us to stop then we let the thread die and stop the I/O

             -- manager.  It will be woken up again when there is more to do.

             case () of
               ()
_ | Bool
exit              -> String -> IO ()
debugIO String
"I/O manager shutting down."
               ()
_ -> Bool -> IO ()
go Bool
use_max_delay


io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word32
io_MANAGER_WAKEUP :: Word32
io_MANAGER_WAKEUP = Word32
4294967295
{-# LINE 1193 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}
io_MANAGER_DIE    = 4294967294
{-# LINE 1194 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}

-- | Wake up a single thread from the I/O Manager's worker queue.  This will

-- unblock a thread blocked in `processCompletion` and allows the I/O manager to

-- react accordingly to changes in timers or to process console signals.

-- No-op if the io-manager is already running.

wakeupIOManager :: IO ()
wakeupIOManager :: IO ()
wakeupIOManager
  = do mngr <- IO Manager
getSystemManager
       -- We don't care about the event handle here, only that it exists.

       _event <- c_getIOManagerEvent
       debugIO "waking up I/O manager."
       startIOManagerThread (io_mngr_loop (error "IOManagerEvent used") mngr)

-- | Returns the signaling event for the IO Manager.

foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c)

  c_getIOManagerEvent :: IO HANDLE

-- | Reads one IO Manager event. For WINIO we distinguish:

-- * Shutdown events, sent from the RTS

-- * Console events, sent from the default console handler.

-- * Wakeup events, which are not used by WINIO and will be ignored

foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c)

  c_readIOManagerEvent :: IO Word32

foreign import ccall unsafe "ioManagerFinished" -- in the RTS (ThrIOManager.c)

  c_ioManagerFinished :: IO ()

foreign import ccall unsafe "rtsSupportsBoundThreads" threadedIOMgr :: Bool

-- | Sleep for n ms

foreign import ccall unsafe "Sleep" sleepBlock :: Int -> IO ()

-- ---------------------------------------------------------------------------

-- I/O manager event notifications



data HandleData = HandleData {
      HandleData -> HandleKey
tokenKey        :: {-# UNPACK #-} !HandleKey
    , HandleData -> EventLifetime
tokenEvents     :: {-# UNPACK #-} !EventLifetime
    , HandleData -> EventCallback
_handleCallback :: !EventCallback
    }

-- | A file handle registration cookie.

data HandleKey = HandleKey {
      HandleKey -> Ptr ()
handleValue  :: {-# UNPACK #-} !HANDLE
    , HandleKey -> Unique
handleUnique :: {-# UNPACK #-} !Unique
    } deriving ( HandleKey -> HandleKey -> Bool
(HandleKey -> HandleKey -> Bool)
-> (HandleKey -> HandleKey -> Bool) -> Eq HandleKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HandleKey -> HandleKey -> Bool
== :: HandleKey -> HandleKey -> Bool
$c/= :: HandleKey -> HandleKey -> Bool
/= :: HandleKey -> HandleKey -> Bool
Eq   -- ^ @since base-4.4.0.0

               , Int -> HandleKey -> String -> String
[HandleKey] -> String -> String
HandleKey -> String
(Int -> HandleKey -> String -> String)
-> (HandleKey -> String)
-> ([HandleKey] -> String -> String)
-> Show HandleKey
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> HandleKey -> String -> String
showsPrec :: Int -> HandleKey -> String -> String
$cshow :: HandleKey -> String
show :: HandleKey -> String
$cshowList :: [HandleKey] -> String -> String
showList :: [HandleKey] -> String -> String
Show -- ^ @since base-4.4.0.0

               )

-- | Callback invoked on I/O events.

type EventCallback = HandleKey -> Event -> IO ()

registerHandle :: Manager -> EventCallback -> HANDLE -> Event -> Lifetime
               -> IO HandleKey
registerHandle :: Manager
-> EventCallback -> Ptr () -> Event -> Lifetime -> IO HandleKey
registerHandle (Manager{Maybe ThreadPool
UniqueSource
MVar (IntTable EventData)
IORef TimeoutQueue
Array OVERLAPPED_ENTRY
IOCP
Clock
mgrIOCP :: Manager -> IOCP
mgrClock :: Manager -> Clock
mgrUniqueSource :: Manager -> UniqueSource
mgrTimeouts :: Manager -> IORef TimeoutQueue
mgrEvntHandlers :: Manager -> MVar (IntTable EventData)
mgrOverlappedEntries :: Manager -> Array OVERLAPPED_ENTRY
mgrThreadPool :: Manager -> Maybe ThreadPool
mgrIOCP :: IOCP
mgrClock :: Clock
mgrUniqueSource :: UniqueSource
mgrTimeouts :: IORef TimeoutQueue
mgrEvntHandlers :: MVar (IntTable EventData)
mgrOverlappedEntries :: Array OVERLAPPED_ENTRY
mgrThreadPool :: Maybe ThreadPool
..}) EventCallback
cb Ptr ()
hwnd Event
evs Lifetime
lt = do
  u <- UniqueSource -> IO Unique
newUnique UniqueSource
mgrUniqueSource
  let reg   = Ptr () -> Unique -> HandleKey
HandleKey Ptr ()
hwnd Unique
u
      hwnd' = IntPtr -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IntPtr -> Int) -> IntPtr -> Int
forall a b. (a -> b) -> a -> b
$ Ptr () -> IntPtr
forall a. Ptr a -> IntPtr
ptrToIntPtr Ptr ()
hwnd
      el    = Event -> Lifetime -> EventLifetime
I.eventLifetime Event
evs Lifetime
lt
      !hwdd = HandleKey -> EventLifetime -> EventCallback -> HandleData
HandleData HandleKey
reg EventLifetime
el EventCallback
cb
      event = Event -> EventElements -> EventData
EventData Event
evs [(Event
evs, HandleData
hwdd)]
  _ <- withMVar mgrEvntHandlers $ \IntTable EventData
evts -> do
          (EventData -> EventData -> EventData)
-> Int -> EventData -> IntTable EventData -> IO (Maybe EventData)
forall a. (a -> a -> a) -> Int -> a -> IntTable a -> IO (Maybe a)
IT.insertWith EventData -> EventData -> EventData
forall a. Monoid a => a -> a -> a
mappend Int
hwnd' EventData
event IntTable EventData
evts
  wakeupIOManager
  return reg

unregisterHandle :: Manager -> HandleKey -> IO ()
unregisterHandle :: Manager -> HandleKey -> IO ()
unregisterHandle (Manager{Maybe ThreadPool
UniqueSource
MVar (IntTable EventData)
IORef TimeoutQueue
Array OVERLAPPED_ENTRY
IOCP
Clock
mgrIOCP :: Manager -> IOCP
mgrClock :: Manager -> Clock
mgrUniqueSource :: Manager -> UniqueSource
mgrTimeouts :: Manager -> IORef TimeoutQueue
mgrEvntHandlers :: Manager -> MVar (IntTable EventData)
mgrOverlappedEntries :: Manager -> Array OVERLAPPED_ENTRY
mgrThreadPool :: Manager -> Maybe ThreadPool
mgrIOCP :: IOCP
mgrClock :: Clock
mgrUniqueSource :: UniqueSource
mgrTimeouts :: IORef TimeoutQueue
mgrEvntHandlers :: MVar (IntTable EventData)
mgrOverlappedEntries :: Array OVERLAPPED_ENTRY
mgrThreadPool :: Maybe ThreadPool
..}) key :: HandleKey
key@HandleKey{Ptr ()
Unique
handleValue :: HandleKey -> Ptr ()
handleUnique :: HandleKey -> Unique
handleValue :: Ptr ()
handleUnique :: Unique
..} = do
  MVar (IntTable EventData) -> (IntTable EventData -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar (IntTable EventData)
mgrEvntHandlers ((IntTable EventData -> IO ()) -> IO ())
-> (IntTable EventData -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IntTable EventData
evts -> do
    let hwnd' :: Int
hwnd' = IntPtr -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IntPtr -> Int) -> IntPtr -> Int
forall a b. (a -> b) -> a -> b
$ Ptr () -> IntPtr
forall a. Ptr a -> IntPtr
ptrToIntPtr Ptr ()
handleValue
    val <- Int -> IntTable EventData -> IO (Maybe EventData)
forall a. Int -> IntTable a -> IO (Maybe a)
IT.lookup Int
hwnd' IntTable EventData
evts
    case val of
      Maybe EventData
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just (EventData Event
evs EventElements
lst) -> do
        let cmp :: (a, HandleData) -> (a, HandleData) -> Bool
cmp (a
_, HandleData
a) (a
_, HandleData
b) = HandleData -> HandleKey
tokenKey HandleData
a HandleKey -> HandleKey -> Bool
forall a. Eq a => a -> a -> Bool
== HandleData -> HandleKey
tokenKey HandleData
b
            key' :: (a, HandleData)
key'    = (a
forall a. HasCallStack => a
undefined, HandleKey -> EventLifetime -> EventCallback -> HandleData
HandleData HandleKey
key EventLifetime
forall a. HasCallStack => a
undefined EventCallback
forall a. HasCallStack => a
undefined)
            updated :: EventElements
updated = ((Event, HandleData) -> (Event, HandleData) -> Bool)
-> (Event, HandleData) -> EventElements -> EventElements
forall a. (a -> a -> Bool) -> a -> [a] -> [a]
deleteBy (Event, HandleData) -> (Event, HandleData) -> Bool
forall {a} {a}. (a, HandleData) -> (a, HandleData) -> Bool
cmp (Event, HandleData)
forall {a}. (a, HandleData)
key' EventElements
lst
            new_lst :: EventData
new_lst = Event -> EventElements -> EventData
EventData Event
evs EventElements
updated
        _ <- (EventData -> Maybe EventData)
-> Int -> IntTable EventData -> IO (Maybe EventData)
forall a. (a -> Maybe a) -> Int -> IntTable a -> IO (Maybe a)
IT.updateWith (\EventData
_ -> EventData -> Maybe EventData
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return EventData
new_lst) Int
hwnd' IntTable EventData
evts
        return ()

-- ---------------------------------------------------------------------------

-- debugging



{-# LINE 1283 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}

debugIO :: String -> IO ()

{-# LINE 1299 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}
debugIO :: String -> IO ()
debugIO String
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

{-# LINE 1301 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows.hsc" #-}

-- dbxIO :: String -> IO ()

-- dbxIO s = do tid <- myThreadId

--              let pref = if threadedIOMgr then "\t" else ""

--              _   <- withCStringLen (pref ++ "winio: " ++ s ++ " (" ++

--                                    showThreadId tid ++ ")\n") $

--                    \(p, len) -> c_write 2 (castPtr p) (fromIntegral len)

--              return ()