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

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

-- |

-- Module      :  GHC.Internal.Event.Windows.FFI

-- Copyright   :  (c) Tamar Christina 2019

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

--

-- Maintainer  :  libraries@haskell.org

-- Stability   :  stable

-- Portability :  non-portable

--

-- WinIO Windows API Foreign Function imports

--

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


module GHC.Internal.Event.Windows.FFI (
    -- * IOCP

    IOCP(..),
    CompletionKey,
    newIOCP,
    associateHandleWithIOCP,
    getQueuedCompletionStatusEx,
    postQueuedCompletionStatus,
    getOverlappedResult,

    -- * Completion Data

    CompletionData(..),
    CompletionCallback,
    withRequest,

    -- * Overlapped

    OVERLAPPED,
    LPOVERLAPPED,
    OVERLAPPED_ENTRY(..),
    LPOVERLAPPED_ENTRY,
    HASKELL_OVERLAPPED,
    LPHASKELL_OVERLAPPED,
    allocOverlapped,
    zeroOverlapped,
    pokeOffsetOverlapped,
    overlappedIOStatus,
    overlappedIONumBytes,

    -- * Cancel pending I/O

    cancelIoEx,
    cancelIoEx',

    -- * Monotonic time


    -- ** GetTickCount

    getTickCount64,

    -- ** QueryPerformanceCounter

    queryPerformanceCounter,
    queryPerformanceFrequency,

    -- ** Miscellaneous

    throwWinErr,
    setLastError
) where





import GHC.Internal.Data.Maybe
import GHC.Internal.Base
import GHC.Internal.Num ((*))
import GHC.Internal.Foreign.Marshal.Alloc
import GHC.Internal.Foreign.Marshal.Utils
import GHC.Internal.Foreign.Storable
import GHC.Internal.Int
import GHC.Internal.Ptr
import GHC.Internal.Word
import GHC.Internal.Stable
import GHC.Internal.Real (fromIntegral)
import GHC.Internal.Show
import GHC.Internal.Windows
import qualified GHC.Internal.Event.Array as A
import qualified GHC.Internal.Windows     as Win32
import GHC.Internal.IO.Handle.Internals (debugIO)

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

-- IOCP


-- | An I/O completion port.

newtype IOCP = IOCP HANDLE
    deriving (IOCP -> IOCP -> Bool
(IOCP -> IOCP -> Bool) -> (IOCP -> IOCP -> Bool) -> Eq IOCP
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IOCP -> IOCP -> Bool
== :: IOCP -> IOCP -> Bool
$c/= :: IOCP -> IOCP -> Bool
/= :: IOCP -> IOCP -> Bool
Eq, Eq IOCP
Eq IOCP =>
(IOCP -> IOCP -> Ordering)
-> (IOCP -> IOCP -> Bool)
-> (IOCP -> IOCP -> Bool)
-> (IOCP -> IOCP -> Bool)
-> (IOCP -> IOCP -> Bool)
-> (IOCP -> IOCP -> IOCP)
-> (IOCP -> IOCP -> IOCP)
-> Ord IOCP
IOCP -> IOCP -> Bool
IOCP -> IOCP -> Ordering
IOCP -> IOCP -> IOCP
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: IOCP -> IOCP -> Ordering
compare :: IOCP -> IOCP -> Ordering
$c< :: IOCP -> IOCP -> Bool
< :: IOCP -> IOCP -> Bool
$c<= :: IOCP -> IOCP -> Bool
<= :: IOCP -> IOCP -> Bool
$c> :: IOCP -> IOCP -> Bool
> :: IOCP -> IOCP -> Bool
$c>= :: IOCP -> IOCP -> Bool
>= :: IOCP -> IOCP -> Bool
$cmax :: IOCP -> IOCP -> IOCP
max :: IOCP -> IOCP -> IOCP
$cmin :: IOCP -> IOCP -> IOCP
min :: IOCP -> IOCP -> IOCP
Ord, Int -> IOCP -> ShowS
[IOCP] -> ShowS
IOCP -> String
(Int -> IOCP -> ShowS)
-> (IOCP -> String) -> ([IOCP] -> ShowS) -> Show IOCP
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IOCP -> ShowS
showsPrec :: Int -> IOCP -> ShowS
$cshow :: IOCP -> String
show :: IOCP -> String
$cshowList :: [IOCP] -> ShowS
showList :: [IOCP] -> ShowS
Show)

type CompletionKey = ULONG_PTR

-- | This function has two distinct purposes depending on the value of

-- The completion port handle:

--

--  - When the IOCP port is NULL then the function creates a new I/O completion

--    port.  See `newIOCP`.

--

--  - When The port contains a valid handle then the given handle is

--    associated with he given completion port handle.  Once associated it

--    cannot be easily changed.  Associating a Handle with a Completion Port

--    allows the I/O manager's worker threads to handle requests to the given

--    handle.

foreign import ccall unsafe "windows.h CreateIoCompletionPort"
    c_CreateIoCompletionPort :: HANDLE -> IOCP -> ULONG_PTR -> DWORD
                             -> IO IOCP

-- | Create a new I/O completion port.

newIOCP :: IO IOCP
newIOCP :: IO IOCP
newIOCP = (IOCP -> Bool) -> String -> IO IOCP -> IO IOCP
forall a. (a -> Bool) -> String -> IO a -> IO a
failIf (IOCP -> IOCP -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr () -> IOCP
IOCP Ptr ()
forall a. Ptr a
nullPtr) String
"newIOCP" (IO IOCP -> IO IOCP) -> IO IOCP -> IO IOCP
forall a b. (a -> b) -> a -> b
$
          Ptr () -> IOCP -> Word64 -> Word32 -> IO IOCP
c_CreateIoCompletionPort Ptr ()
iNVALID_HANDLE_VALUE (Ptr () -> IOCP
IOCP Ptr ()
forall a. Ptr a
nullPtr) Word64
0 Word32
0

-- | Associate a HANDLE with an I/O completion port.

associateHandleWithIOCP :: IOCP -> HANDLE -> CompletionKey -> IO ()
associateHandleWithIOCP :: IOCP -> Ptr () -> Word64 -> IO ()
associateHandleWithIOCP IOCP
iocp Ptr ()
handle Word64
completionKey =
    (IOCP -> Bool) -> String -> IO IOCP -> IO ()
forall a. (a -> Bool) -> String -> IO a -> IO ()
failIf_ (IOCP -> IOCP -> Bool
forall a. Eq a => a -> a -> Bool
/= IOCP
iocp) String
"associateHandleWithIOCP" (IO IOCP -> IO ()) -> IO IOCP -> IO ()
forall a b. (a -> b) -> a -> b
$
        Ptr () -> IOCP -> Word64 -> Word32 -> IO IOCP
c_CreateIoCompletionPort Ptr ()
handle IOCP
iocp Word64
completionKey Word32
0

foreign import ccall safe "windows.h GetOverlappedResult"
    c_GetOverlappedResult :: HANDLE -> LPOVERLAPPED -> Ptr DWORD -> BOOL
                          -> IO BOOL

-- | Get the result of a single overlap operation without the IO manager

getOverlappedResult :: HANDLE -> Ptr OVERLAPPED -> BOOL -> IO (Maybe DWORD)
getOverlappedResult :: Ptr () -> Ptr OVERLAPPED -> Bool -> IO (Maybe Word32)
getOverlappedResult Ptr ()
handle Ptr OVERLAPPED
lp Bool
block
  = (Ptr Word32 -> IO (Maybe Word32)) -> IO (Maybe Word32)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Word32 -> IO (Maybe Word32)) -> IO (Maybe Word32))
-> (Ptr Word32 -> IO (Maybe Word32)) -> IO (Maybe Word32)
forall a b. (a -> b) -> a -> b
$ \Ptr Word32
bytes ->
        do res <- Ptr () -> Ptr OVERLAPPED -> Ptr Word32 -> Bool -> IO Bool
c_GetOverlappedResult Ptr ()
handle Ptr OVERLAPPED
lp Ptr Word32
bytes Bool
block
           if res
              then fmap Just $ peek bytes
              else return Nothing

foreign import ccall safe "windows.h GetQueuedCompletionStatusEx"
    c_GetQueuedCompletionStatusEx :: IOCP -> LPOVERLAPPED_ENTRY -> Word32
                                  -> Ptr ULONG -> DWORD -> BOOL -> IO BOOL

-- | Note [Completion Ports]

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

-- When an I/O operation has been queued by an operation

-- (ReadFile/WriteFile/etc) it is placed in a queue that the driver uses when

-- servicing IRQs.  This queue has some important properties:

--

-- 1.) It is not an ordered queue.  Requests may be performed out of order as

--     as the OS's native I/O manager may try to re-order requests such that as

--     few random seeks as possible are needed to complete the pending

--     operations.  As such do not assume a fixed order between something being

--     queued and dequeued.

--

-- 2.) Operations may skip the queue entirely.  In which case they do not end in

--     in this function. (This is an optimization flag we have turned on. See

--     `openFile`.)

--

-- 3.) Across this call the specified OVERLAPPED_ENTRY buffer MUST remain live,

--     and the buffer for an I/O operation cannot be freed or moved until

--     `getOverlappedResult` says it's done.  The reason is the kernel may not

--     have fully released the buffer, or finished writing to it when this

--     operation returns.  Failure to adhere to this will cause your IRQs to be

--     silently dropped and your program will never receive a completion for it.

--     This means that the OVERLAPPED buffer must also remain valid for the

--     duration of the call and as such must be allocated on the unmanaged heap.

--

-- 4.) When a thread calls this method it is associated with the I/O manager's

--     worker threads pool.  You should always use dedicated threads for this

--     since the OS I/O manager will now monitor the threads.  If the thread

--     becomes blocked for whatever reason, the Haskell I/O manager will wake up

--     another threads from it's pool to service the remaining results.

--     A new thread will also be woken up from the pool when the previous thread

--     is busy servicing requests and new requests have finished.  For this

--     reason the Haskell I/O manager multiplexes I/O operations from N haskell

--     threads into 1 completion port, which is serviced by M native threads in

--     an asynchronous method. This allows it to scale efficiently.

getQueuedCompletionStatusEx :: IOCP
                            -> A.Array OVERLAPPED_ENTRY
                            -> DWORD  -- ^ Timeout in milliseconds (or

                                      -- 'GHC.Internal.Windows.iNFINITE')

                            -> IO Int
getQueuedCompletionStatusEx :: IOCP -> Array OVERLAPPED_ENTRY -> Word32 -> IO Int
getQueuedCompletionStatusEx IOCP
iocp Array OVERLAPPED_ENTRY
arr Word32
timeout =
    (Ptr Word32 -> IO Int) -> IO Int
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Word32 -> IO Int) -> IO Int)
-> (Ptr Word32 -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Ptr Word32
num_removed_ptr ->do
        Array OVERLAPPED_ENTRY
-> (Ptr OVERLAPPED_ENTRY -> Int -> IO Int) -> IO Int
forall a. Array a -> (Ptr a -> Int -> IO Int) -> IO Int
A.unsafeLoad Array OVERLAPPED_ENTRY
arr ((Ptr OVERLAPPED_ENTRY -> Int -> IO Int) -> IO Int)
-> (Ptr OVERLAPPED_ENTRY -> Int -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Ptr OVERLAPPED_ENTRY
oes Int
cap -> do
            -- TODO: remove after debugging

            Ptr OVERLAPPED_ENTRY -> Word8 -> Int -> IO ()
forall a. Ptr a -> Word8 -> Int -> IO ()
fillBytes Ptr OVERLAPPED_ENTRY
oes Word8
0 (Int
cap Int -> Int -> Int
forall a. Num a => a -> a -> a
* (OVERLAPPED_ENTRY -> Int
forall a. Storable a => a -> Int
sizeOf (OVERLAPPED_ENTRY
forall a. HasCallStack => a
undefined :: OVERLAPPED_ENTRY)))
            String -> IO ()
debugIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"-- call getQueuedCompletionStatusEx "
            -- don't block the call if the rts is not supporting threads.

            -- this would block the entire program.

            let alertable :: Bool
alertable = Bool
False -- not rtsSupportsBoundThreads

            ok <- IOCP
-> Ptr OVERLAPPED_ENTRY
-> Word32
-> Ptr Word32
-> Word32
-> Bool
-> IO Bool
c_GetQueuedCompletionStatusEx IOCP
iocp Ptr OVERLAPPED_ENTRY
oes (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cap)
                  Ptr Word32
num_removed_ptr Word32
timeout Bool
alertable
            debugIO $ "-- call getQueuedCompletionStatusEx: " ++ show ok
            err <- getLastError
            nc <- (peek num_removed_ptr)
            debugIO $ "-- getQueuedCompletionStatusEx: n=" ++ show nc ++ " ,err=" ++ show err
            if ok then fromIntegral `fmap` peek num_removed_ptr
            else do debugIO $ "failed getQueuedCompletionStatusEx: " ++ show err
                    if err == 258 || alertable then return 0
{-# LINE 200 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}
                    else failWith "GetQueuedCompletionStatusEx" err

overlappedIOStatus :: LPOVERLAPPED -> IO NTSTATUS
overlappedIOStatus :: Ptr OVERLAPPED -> IO Int32
overlappedIOStatus Ptr OVERLAPPED
lpol = do
  status <- (\Ptr OVERLAPPED
hsc_ptr -> Ptr OVERLAPPED -> Int -> IO Int32
forall b. Ptr b -> Int -> IO Int32
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr OVERLAPPED
hsc_ptr Int
0) Ptr OVERLAPPED
lpol
{-# LINE 205 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}
  -- TODO: Map NTSTATUS to ErrCode?

  -- See https://github.com/libuv/libuv/blob/b12624c13693c4d29ca84b3556eadc9e9c0936a4/src/win/winsock.c#L153

  return status
{-# INLINE overlappedIOStatus #-}

overlappedIONumBytes :: LPOVERLAPPED -> IO ULONG_PTR
overlappedIONumBytes :: Ptr OVERLAPPED -> IO Word64
overlappedIONumBytes Ptr OVERLAPPED
lpol = do
  bytes <- (\Ptr OVERLAPPED
hsc_ptr -> Ptr OVERLAPPED -> Int -> IO Word64
forall b. Ptr b -> Int -> IO Word64
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr OVERLAPPED
hsc_ptr Int
8) Ptr OVERLAPPED
lpol
{-# LINE 213 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}
  return bytes
{-# INLINE overlappedIONumBytes #-}

foreign import ccall unsafe "windows.h PostQueuedCompletionStatus"
    c_PostQueuedCompletionStatus :: IOCP -> DWORD -> ULONG_PTR -> LPOVERLAPPED
                                 -> IO BOOL

-- | Manually post a completion to the specified I/O port.  This will wake up

-- a thread waiting `GetQueuedCompletionStatusEx`.

postQueuedCompletionStatus :: IOCP -> DWORD -> CompletionKey -> LPOVERLAPPED
                           -> IO ()
postQueuedCompletionStatus :: IOCP -> Word32 -> Word64 -> Ptr OVERLAPPED -> IO ()
postQueuedCompletionStatus IOCP
iocp Word32
numBytes Word64
completionKey Ptr OVERLAPPED
lpol =
    String -> IO Bool -> IO ()
failIfFalse_ String
"PostQueuedCompletionStatus" (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$
    IOCP -> Word32 -> Word64 -> Ptr OVERLAPPED -> IO Bool
c_PostQueuedCompletionStatus IOCP
iocp Word32
numBytes Word64
completionKey Ptr OVERLAPPED
lpol

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

-- Completion Data


-- | Called when the completion is delivered.

type CompletionCallback a = ErrCode   -- ^ 0 indicates success

                          -> DWORD     -- ^ Number of bytes transferred

                          -> IO a

-- | Callback type that will be called when an I/O operation completes.

type IOCallback = CompletionCallback ()

-- | Structure that the I/O manager uses to associate callbacks with

-- additional payload such as their OVERLAPPED structure and Win32 handle

-- etc.  *Must* be kept in sync with that in `winio_structs.h` or horrible things

-- happen.

--

-- We keep the handle around for the benefit of ghc-external libraries making

-- use of the manager.

data CompletionData = CompletionData { CompletionData -> Ptr ()
cdHandle   :: !HANDLE
                                     , CompletionData -> StablePtr IOCallback
cdCallback :: !(StablePtr IOCallback)
                                     }

instance Storable CompletionData where
    sizeOf :: CompletionData -> Int
sizeOf CompletionData
_    = (Int
16)
{-# LINE 252 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}
    alignment _ = 8
{-# LINE 253 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}

    peek :: Ptr CompletionData -> IO CompletionData
peek Ptr CompletionData
ptr = do
      cdCallback <- (\Ptr CompletionData
hsc_ptr -> Ptr CompletionData -> Int -> IO (StablePtr IOCallback)
forall b. Ptr b -> Int -> IO (StablePtr IOCallback)
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr CompletionData
hsc_ptr Int
8) Ptr CompletionData
ptr
{-# LINE 256 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}
      cdHandle   <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr
{-# LINE 257 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}
      let !cd = CompletionData{..}
      return cd

    poke :: Ptr CompletionData -> CompletionData -> IO ()
poke Ptr CompletionData
ptr CompletionData{StablePtr IOCallback
Ptr ()
cdHandle :: CompletionData -> Ptr ()
cdCallback :: CompletionData -> StablePtr IOCallback
cdHandle :: Ptr ()
cdCallback :: StablePtr IOCallback
..} = do
      (\Ptr CompletionData
hsc_ptr -> Ptr CompletionData -> Int -> StablePtr IOCallback -> IO ()
forall b. Ptr b -> Int -> StablePtr IOCallback -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr CompletionData
hsc_ptr Int
8) Ptr CompletionData
ptr StablePtr IOCallback
cdCallback
{-# LINE 262 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}
      (\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr cdHandle
{-# LINE 263 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}

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

-- Overlapped


-- | Tag type for @LPOVERLAPPED@.

data OVERLAPPED

-- | Tag type for the extended version of @OVERLAPPED@ containing some book

--   keeping information.

data HASKELL_OVERLAPPED

-- | Identifies an I/O operation.  Used as the @LPOVERLAPPED@ parameter

-- for overlapped I/O functions (e.g. @ReadFile@, @WSASend@).

type LPOVERLAPPED = Ptr OVERLAPPED

-- | Pointer to the extended HASKELL_OVERLAPPED function.

type LPHASKELL_OVERLAPPED = Ptr HASKELL_OVERLAPPED

-- | An array of these is passed to GetQueuedCompletionStatusEx as an output

-- argument.

data OVERLAPPED_ENTRY = OVERLAPPED_ENTRY {
      OVERLAPPED_ENTRY -> Word64
lpCompletionKey            :: ULONG_PTR,
      OVERLAPPED_ENTRY -> Ptr OVERLAPPED
lpOverlapped               :: LPOVERLAPPED,
      OVERLAPPED_ENTRY -> Word32
dwNumberOfBytesTransferred :: DWORD
    }

type LPOVERLAPPED_ENTRY = Ptr OVERLAPPED_ENTRY

instance Storable OVERLAPPED_ENTRY where
    sizeOf :: OVERLAPPED_ENTRY -> Int
sizeOf OVERLAPPED_ENTRY
_    = (Int
32)
{-# LINE 293 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}
    alignment _ = 8
{-# LINE 294 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}

    peek :: Ptr OVERLAPPED_ENTRY -> IO OVERLAPPED_ENTRY
peek Ptr OVERLAPPED_ENTRY
ptr = do
      lpCompletionKey <- (\Ptr OVERLAPPED_ENTRY
hsc_ptr -> Ptr OVERLAPPED_ENTRY -> Int -> IO Word64
forall b. Ptr b -> Int -> IO Word64
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr OVERLAPPED_ENTRY
hsc_ptr Int
0) Ptr OVERLAPPED_ENTRY
ptr
{-# LINE 297 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}
      lpOverlapped    <- (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr
{-# LINE 298 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}
      dwNumberOfBytesTransferred <-
          (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr
{-# LINE 300 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}
      let !oe = OVERLAPPED_ENTRY{..}
      return oe

    poke :: Ptr OVERLAPPED_ENTRY -> OVERLAPPED_ENTRY -> IO ()
poke Ptr OVERLAPPED_ENTRY
ptr OVERLAPPED_ENTRY{Word32
Word64
Ptr OVERLAPPED
lpCompletionKey :: OVERLAPPED_ENTRY -> Word64
lpOverlapped :: OVERLAPPED_ENTRY -> Ptr OVERLAPPED
dwNumberOfBytesTransferred :: OVERLAPPED_ENTRY -> Word32
lpCompletionKey :: Word64
lpOverlapped :: Ptr OVERLAPPED
dwNumberOfBytesTransferred :: Word32
..} = do
      (\Ptr OVERLAPPED_ENTRY
hsc_ptr -> Ptr OVERLAPPED_ENTRY -> Int -> Word64 -> IO ()
forall b. Ptr b -> Int -> Word64 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr OVERLAPPED_ENTRY
hsc_ptr Int
0) Ptr OVERLAPPED_ENTRY
ptr Word64
lpCompletionKey
{-# LINE 305 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}
      (\hsc_ptr -> pokeByteOff hsc_ptr 8) ptr lpOverlapped
{-# LINE 306 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}
      (\hsc_ptr -> pokeByteOff hsc_ptr 24)
{-# LINE 307 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}
        ptr dwNumberOfBytesTransferred

-- | Allocate a new

-- <http://msdn.microsoft.com/en-us/library/windows/desktop/ms684342%28v=vs.85%29.aspx

-- OVERLAPPED> structure on the unmanaged heap. This also zeros the memory to

-- prevent the values inside the struct to be incorrectly interpreted as data

-- payload.

--

-- We extend the overlapped structure with some extra book keeping information

-- such that we don't have to do a lookup on the Haskell side.

--

-- Future: We can gain some performance here by using a pool instead of calling

--         malloc for each request. A simple block allocator would be very

--         useful here, especially when we implement sockets support.

allocOverlapped :: Word64 -- ^ Offset/OffsetHigh

                -> IO (Ptr HASKELL_OVERLAPPED)
allocOverlapped :: Word64 -> IO (Ptr HASKELL_OVERLAPPED)
allocOverlapped Word64
offset = do
  lpol <- Int -> IO (Ptr HASKELL_OVERLAPPED)
forall a. Int -> IO (Ptr a)
mallocBytes (Int
40)
{-# LINE 325 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}
  zeroOverlapped lpol
  pokeOffsetOverlapped (castPtr lpol) offset
  return lpol

-- | Zero-fill an HASKELL_OVERLAPPED structure.

zeroOverlapped :: LPHASKELL_OVERLAPPED -> IO ()
zeroOverlapped :: Ptr HASKELL_OVERLAPPED -> IO ()
zeroOverlapped Ptr HASKELL_OVERLAPPED
lpol = Ptr HASKELL_OVERLAPPED -> Word8 -> Int -> IO ()
forall a. Ptr a -> Word8 -> Int -> IO ()
fillBytes Ptr HASKELL_OVERLAPPED
lpol Word8
0 (Int
40)
{-# LINE 332 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}
{-# INLINE zeroOverlapped #-}

-- | Set the offset field in an OVERLAPPED structure.

pokeOffsetOverlapped :: LPOVERLAPPED -> Word64 -> IO ()
pokeOffsetOverlapped :: Ptr OVERLAPPED -> Word64 -> IO ()
pokeOffsetOverlapped Ptr OVERLAPPED
lpol Word64
offset = do
  let (Word32
offsetHigh, Word32
offsetLow) = Word64 -> (Word32, Word32)
Win32.ddwordToDwords Word64
offset
  (\Ptr OVERLAPPED
hsc_ptr -> Ptr OVERLAPPED -> Int -> Word32 -> IO ()
forall b. Ptr b -> Int -> Word32 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr OVERLAPPED
hsc_ptr Int
16) Ptr OVERLAPPED
lpol Word32
offsetLow
{-# LINE 339 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}
  (\hsc_ptr -> pokeByteOff hsc_ptr 20) lpol offsetHigh
{-# LINE 340 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}
{-# INLINE pokeOffsetOverlapped #-}

-- | Set the event field in an OVERLAPPED structure.

pokeEventOverlapped :: LPOVERLAPPED -> HANDLE -> IO ()
pokeEventOverlapped :: Ptr OVERLAPPED -> Ptr () -> IO ()
pokeEventOverlapped Ptr OVERLAPPED
lpol Ptr ()
event = do
  (\Ptr OVERLAPPED
hsc_ptr -> Ptr OVERLAPPED -> Int -> Ptr () -> IO ()
forall b. Ptr b -> Int -> Ptr () -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr OVERLAPPED
hsc_ptr Int
24) Ptr OVERLAPPED
lpol Ptr ()
event
{-# LINE 346 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}
{-# INLINE pokeEventOverlapped #-}

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

-- Request management


-- Note [AsyncHandles]

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

-- In `winio` we have designed it to work in asynchronous mode always.

-- According to the MSDN documentation[1][2], when a handle is not opened

-- in asynchronous mode then the operation would simply work but operate

-- synchronously.

--

-- This seems to happen as documented for `File` handles, but `pipes` don't

-- seem to follow this documented behavior and so are a problem.

-- Under `msys2` your standard handles are actually pipes, not console

-- handles or files.  As such running under an msys2 console causes a hang

-- as the pipe read never returns.

--

-- [1] https://docs.microsoft.com/en-us/windows/win32/fileio/synchronous-and-asynchronous-i-o

-- [2] https://docs.microsoft.com/en-us/windows/win32/sync/synchronization-and-overlapped-input-and-output

--

-- As such we need to annotate all NativeHandles with a Boolean to indicate

-- whether it's an asynchronous handle or not.

-- This allows us to manually wait for the completion instead of relying

-- on the I/O system to do the right thing.  As we have been using the

-- buffers in async mode we may not have moved the file pointer on the kernel

-- object, as such we still need to give an `OVERLAPPED` structure, but we

-- instead create an event object that we can wait on.

--

-- As documented in MSDN this even object must be in manual reset mode.  This

-- approach gives us the flexibility, with minimum impact to support both

-- synchronous and asynchronous access.

--

-- Additional approaches explored

--

-- Normally the I/O system is in full control of all Handles it creates, with

-- one big exception: inheritance.

--

-- For any `HANDLE` we inherit we don't know how it's been open.  A different

-- solution I have explored was to try to detect the `HANDLE` mode.

-- But this approach would never work for a few reasons:

--

-- 1. The presence of an asynchronous flag does not indicate that we are able

--    to handle the operation asynchronously.  In particular, just because a

--    `HANDLE` is open in async mode, it may not be associated with our

--    completion port.

-- 2. One can only associate a `HANDLE` to a *single* completion port.  As

--    such, if the handle is opened in async mode but already registered to a

--    completion port then we can't use it asynchronously.

-- 3. You can only associate a completion port once, even if it's the same

--    port.  This means were we to strap a `HANDLE` of it's `NativeHandle`

--    wrapper and then wrap it again, we can't retest as the result would be

--    invalid.  This is an issue because to pass `HANDLE`s we have to pass

--    the native OS Handle not the Haskell one. i.e. remote-iserv.


-- See Note [AsyncHandles]

withRequest :: Bool -> Word64 -> HANDLE -> IOCallback
            -> (Ptr HASKELL_OVERLAPPED -> Ptr CompletionData -> IO a)
            -> IO a
withRequest :: forall a.
Bool
-> Word64
-> Ptr ()
-> IOCallback
-> (Ptr HASKELL_OVERLAPPED -> Ptr CompletionData -> IO a)
-> IO a
withRequest Bool
async Word64
offset Ptr ()
hdl IOCallback
cb Ptr HASKELL_OVERLAPPED -> Ptr CompletionData -> IO a
f = do
    -- Create the completion record and store it.

    -- We only need the record when we enqueue a request, however if we

    -- delay creating it then we will run into a race condition where the

    -- driver may have finished servicing the request before we were ready

    -- and so the request won't have the book keeping information to know

    -- what to do.  So because of that we always create the payload,  If we

    -- need it ok, if we don't that's no problem.  This approach prevents

    -- expensive lookups in hash-tables.

    --

    -- Todo: Use a memory pool for this so we don't have to hit malloc every

    --       time.  This would allow us to scale better.

    cb_sptr <- IOCallback -> IO (StablePtr IOCallback)
forall a. a -> IO (StablePtr a)
newStablePtr IOCallback
cb
    let cbData :: CompletionData
        cbData = Ptr () -> StablePtr IOCallback -> CompletionData
CompletionData Ptr ()
hdl StablePtr IOCallback
cb_sptr
    r <- allocaBytes (40) $ \Ptr HASKELL_OVERLAPPED
hs_lpol ->
{-# LINE 421 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}
      with cbData $ \cdData -> do
        zeroOverlapped hs_lpol
        let lpol = castPtr hs_lpol
        pokeOffsetOverlapped lpol offset
        -- If doing a synchronous request then register an event object.

        -- This event object MUST be manual reset per MSDN.

        case async of
          True -> f hs_lpol cdData
          False -> do
            event <- failIfNull "withRequest (create)" $
                       c_CreateEvent nullPtr True False nullPtr
            debugIO $ "{{ event " ++ show event ++ " for " ++ show hs_lpol
            pokeEventOverlapped lpol event
            res <- f hs_lpol cdData
            -- Once the request has finished, close the object and free it.

            failIfFalse_ "withRequest (free)" $ c_CloseHandle event
            return res

    freeStablePtr cb_sptr
    return r


-- | Create an event object for use when the HANDLE isn't asynchronous

foreign import ccall unsafe "windows.h CreateEventW"
    c_CreateEvent :: Ptr () -> Bool -> Bool -> LPCWSTR -> IO HANDLE

-- | Close a handle object

foreign import ccall unsafe "windows.h CloseHandle"
    c_CloseHandle :: HANDLE -> IO Bool

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

-- Cancel pending I/O


-- | CancelIo shouldn't block, but cancellation happens infrequently,

-- so we might as well be on the safe side.

foreign import ccall unsafe "windows.h CancelIoEx"
    c_CancelIoEx :: HANDLE -> LPOVERLAPPED -> IO BOOL

-- | Cancel all pending overlapped I/O for the given file that was initiated by

-- the current OS thread.  Cancelling is just a request for cancellation and

-- before the OVERLAPPED struct is freed we must make sure that the IRQ has been

-- removed from the queue.  See `getOverlappedResult`.

cancelIoEx :: HANDLE -> LPOVERLAPPED -> IO ()
cancelIoEx :: Ptr () -> Ptr OVERLAPPED -> IO ()
cancelIoEx Ptr ()
h Ptr OVERLAPPED
o = String -> IO Bool -> IO ()
failIfFalse_ String
"CancelIoEx" (IO Bool -> IO ())
-> (Ptr OVERLAPPED -> IO Bool) -> Ptr OVERLAPPED -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr () -> Ptr OVERLAPPED -> IO Bool
c_CancelIoEx Ptr ()
h (Ptr OVERLAPPED -> IO ()) -> Ptr OVERLAPPED -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr OVERLAPPED
o

cancelIoEx' :: HANDLE -> LPOVERLAPPED -> IO Bool
cancelIoEx' :: Ptr () -> Ptr OVERLAPPED -> IO Bool
cancelIoEx' = Ptr () -> Ptr OVERLAPPED -> IO Bool
c_CancelIoEx

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

-- Monotonic time


foreign import ccall "windows.h GetTickCount64"
    c_GetTickCount64 :: IO Word64
{-# LINE 474 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}

-- | Call the @GetTickCount64@ function, which returns a monotonic time in

-- milliseconds.

--

-- Problems:

--

--  * Low resolution (10 to 16 milliseconds).

--

-- <http://msdn.microsoft.com/en-us/library/windows/desktop/ms724408%28v=vs.85%29.aspx>

getTickCount64 :: IO Word64
getTickCount64 :: IO Word64
getTickCount64 = IO Word64
c_GetTickCount64

-- | Call the @QueryPerformanceCounter@ function.

--

-- Problems:

--

--  * Might not be available on some hardware.  Use 'queryPerformanceFrequency'

--    to test for availability before calling this function.

--

--  * On a multiprocessor computer, may produce different results on

--    different processors due to hardware bugs.

--

-- To get a monotonic time in seconds, divide the result of

-- 'queryPerformanceCounter' by that of 'queryPerformanceFrequency'.

--

-- <http://msdn.microsoft.com/en-us/library/windows/desktop/ms644904%28v=vs.85%29.aspx>

queryPerformanceCounter :: IO Int64
queryPerformanceCounter :: IO Int64
queryPerformanceCounter =
    QPFunc -> IO (Maybe Int64)
callQP QPFunc
c_QueryPerformanceCounter
    IO (Maybe Int64) -> (Maybe Int64 -> IO Int64) -> IO Int64
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Int64 -> (Int64 -> IO Int64) -> Maybe Int64 -> IO Int64
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO Int64
forall a. String -> IO a
throwGetLastError String
"QueryPerformanceCounter") Int64 -> IO Int64
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Call the @QueryPerformanceFrequency@ function.  Return 'Nothing' if the

-- hardware does not provide a high-resolution performance counter.

--

-- <http://msdn.microsoft.com/en-us/library/windows/desktop/ms644905%28v=vs.85%29.aspx>

queryPerformanceFrequency :: IO (Maybe Int64)
queryPerformanceFrequency :: IO (Maybe Int64)
queryPerformanceFrequency = do
    m <- QPFunc -> IO (Maybe Int64)
callQP QPFunc
c_QueryPerformanceFrequency
    case m of
        Maybe Int64
Nothing   -> Maybe Int64 -> IO (Maybe Int64)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int64
forall a. Maybe a
Nothing
        Just Int64
0    -> Maybe Int64 -> IO (Maybe Int64)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int64
forall a. Maybe a
Nothing -- Shouldn't happen; just a safeguard to

                                    -- avoid a zero denominator.

        Just Int64
freq -> Maybe Int64 -> IO (Maybe Int64)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
freq)

type QPFunc = Ptr Int64 -> IO BOOL

foreign import ccall "Windows.h QueryPerformanceCounter"
    c_QueryPerformanceCounter :: QPFunc

foreign import ccall "Windows.h QueryPerformanceFrequency"
    c_QueryPerformanceFrequency :: QPFunc

callQP :: QPFunc -> IO (Maybe Int64)
callQP :: QPFunc -> IO (Maybe Int64)
callQP QPFunc
qpfunc =
    Int -> (Ptr Int64 -> IO (Maybe Int64)) -> IO (Maybe Int64)
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes (Int
8) ((Ptr Int64 -> IO (Maybe Int64)) -> IO (Maybe Int64))
-> (Ptr Int64 -> IO (Maybe Int64)) -> IO (Maybe Int64)
forall a b. (a -> b) -> a -> b
$ \Ptr Int64
ptr -> do
{-# LINE 529 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}
        ok <- QPFunc
qpfunc Ptr Int64
ptr
        if ok then do
            n <- (\Ptr Int64
hsc_ptr -> Ptr Int64 -> Int -> IO Int64
forall b. Ptr b -> Int -> IO Int64
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Int64
hsc_ptr Int
0) ptr
{-# LINE 532 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}
            return (Just n)
        else
            return Nothing

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

-- Miscellaneous


type ULONG_PTR  = Word64
{-# LINE 540 "libraries\\ghc-internal\\src\\GHC\\Internal\\Event\\Windows\\FFI.hsc" #-}

throwWinErr :: String -> ErrCode -> IO a
throwWinErr :: forall a. String -> Word32 -> IO a
throwWinErr String
loc Word32
err = do
    Word32 -> IO ()
c_SetLastError Word32
err
    String -> Word32 -> IO a
forall a. String -> Word32 -> IO a
Win32.failWith String
loc Word32
err

setLastError :: ErrCode -> IO ()
setLastError :: Word32 -> IO ()
setLastError = Word32 -> IO ()
c_SetLastError

foreign import ccall unsafe "windows.h SetLastError"
    c_SetLastError :: ErrCode -> IO ()