winio: Minor comments/renamings

1 files changed, 50 insertions, 43 deletions

diff --git a/libraries/base/GHC/Event/Windows.hsc b/libraries/base/GHC/Event/Windows.hsc
index 823d237900..e70464d444 100644
--- a/libraries/base/GHC/Event/Windows.hsc
+++ b/libraries/base/GHC/Event/Windows.hsc
@@ -5,6 +5,7 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 -------------------------------------------------------------------------------
 -- |
@@ -254,7 +255,11 @@ import {-# SOURCE #-} Debug.Trace (traceEventIO)
 --
 
 -- ---------------------------------------------------------------------------
--- I/O manager resume/suspend code
+-- 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)
@@ -268,8 +273,8 @@ foreign import ccall unsafe "getOrSetGHCConcWindowsIOManagerThreadStore"
 -- ---------------------------------------------------------------------------
 -- Non-threaded I/O manager callback hooks. See `ASyncWinIO.c`
 
-foreign import ccall safe "registerNewIOCPHandle"
-  registerNewIOCPHandle :: FFI.IOCP -> IO ()
+foreign import ccall safe "registerIOCPHandle"
+  registerIOCPHandle :: FFI.IOCP -> IO ()
 
 foreign import ccall safe "registerAlertableWait"
 -- (bool has_timeout, DWORD mssec, uint64_t num_req, bool pending_service);
@@ -295,10 +300,13 @@ foreign import ccall "wrapper"
 foreign import ccall "dynamic"
   mkIOCallback :: FunPtr IOCallback -> IOCallback
 
--- | Structure that the I/O managed uses to to associate callbacks with
--- it's additional payload such as it's OVERLAPPED structure and Win32 handle
--- etc.  Must be kept in sync with that in `winio_structs.h` or horrible things
+-- | 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 { cdHandle   :: !HANDLE
                                      , cdCallback :: !IOCallback
                                      }
@@ -308,15 +316,15 @@ instance Storable CompletionData where
     alignment _ = #{alignment CompletionData}
 
     peek ptr = do
-      cdHandle   <- #{peek CompletionData, cdHandle} ptr
       cdCallback <- mkIOCallback `fmap` #{peek CompletionData, cdCallback} ptr
+      cdHandle   <- #{peek CompletionData, cdHandle} ptr
       let !cd = CompletionData{..}
       return cd
 
     poke ptr CompletionData{..} = do
-      #{poke CompletionData, cdHandle} ptr cdHandle
       cb <- wrapIOCallback cdCallback
       #{poke CompletionData, cdCallback} ptr cb
+      #{poke CompletionData, cdHandle} ptr cdHandle
 
 -- | Pointer offset in bytes to the location of hoData in HASKELL_OVERLAPPPED
 cdOffset :: Int
@@ -370,7 +378,7 @@ newManager = do
     debugIO "Starting io-manager..."
     mgrIOCP         <- FFI.newIOCP
     when (not threadedIOMgr) $
-      registerNewIOCPHandle mgrIOCP
+      registerIOCPHandle mgrIOCP
     debugIO $ "iocp: " ++ show mgrIOCP
     mgrClock             <- getClock
     mgrUniqueSource      <- newSource
@@ -388,6 +396,8 @@ newManager = do
 -- 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 loop
   | not threadedIOMgr
@@ -476,7 +486,7 @@ type StartIOCallback a = StartCallback (CbResult a)
 -- an I/O Completion call could be in.
 data CbResult a
   = CbDone (Maybe DWORD) -- ^ Request was handled immediately, no queue.
-  | CbPending            -- ^ Queued and handled by I/O manager
+  | 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
@@ -518,9 +528,10 @@ associateHandle Manager{..} h =
 -- 'withOverlapped' waits for a completion to arrive before returning or
 -- throwing an exception.  This means you can use functions like
 -- 'Foreign.Marshal.Alloc.alloca' to allocate buffers for the operation.
-withOverlappedEx :: Manager
+withOverlappedEx :: forall a.
+                    Manager
                  -> String -- ^ Handle name
-                 -> HANDLE
+                 -> HANDLE -- ^ Windows handle associated with the operation.
                  -> Word64 -- ^ Value to use for the @OVERLAPPED@
                            --   structure's Offset/OffsetHigh members.
                  -> StartIOCallback Int
@@ -528,10 +539,9 @@ withOverlappedEx :: Manager
                  -> IO (IOResult a)
 withOverlappedEx mgr fname h offset startCB completionCB = do
     signal <- newEmptyIOPort :: IO (IOPort (IOResult a))
-    let dbg s = s ++ " (" ++ show h ++ ":" ++ show offset ++ ")"
-    let signalReturn a = failIfFalse_ (dbg "signalReturn") $
+    let signalReturn a = failIfFalse_ (dbgMsg "signalReturn") $
                             writeIOPort signal (IOSuccess a)
-        signalThrow ex = failIfFalse_ (dbg "signalThrow") $
+        signalThrow ex = failIfFalse_ (dbgMsg "signalThrow") $
                             writeIOPort signal (IOFailed ex)
     mask_ $ do
         let completionCB' e b = completionCB e b >>= \result ->
@@ -550,14 +560,14 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
         --
         -- Todo: Use a memory pool for this so we don't have to hit malloc every
         --       time.  This would allow us to scale better.
-        cdData <- new (CompletionData h completionCB')
+        cdData <- new (CompletionData h completionCB') :: IO (Ptr CompletionData)
         let ptr_lpol = hs_lpol `plusPtr` cdOffset
         let lpol = castPtr hs_lpol
         debugIO $ "hs_lpol:" ++ show hs_lpol
                 ++ " cdData:" ++ show cdData
                 ++ " ptr_lpol:" ++ show ptr_lpol
 
-        execute <- startCB lpol `onException`
+        startCBResult <- startCB lpol `onException`
                         (CbError `fmap` Win32.getLastError) >>= \result -> do
           -- Check to see if the operation was completed on a
           -- non-overlapping handle or was completed immediately.
@@ -596,14 +606,14 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
                              | otherwise                                   -> CbPending
                   _                                                        -> result
           case result' of
-            CbNone    _ -> error "shouldn't happen."
+            CbNone    _ -> error "withOverlappedEx: CbNone shouldn't happen."
             CbIncomplete -> do
                debugIO $ "handling incomplete request synchronously " ++ show (h, lpol)
                res <- spinWaitComplete h lpol
                debugIO $ "done blocking request 2: " ++ show (h, lpol) ++ " - " ++ show res
                return res
             CbPending   -> do
-              -- Before we enqueue check to see if operation finished in the
+              -- 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
@@ -640,7 +650,8 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
                     poke ptr_lpol cdData
                     reqs <- addRequest
                     debugIO $ "+1.. " ++ show reqs ++ " requests queued. | " ++ show lpol
-                    --wakeupIOManager
+                    -- 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.
                     return result'
                 -- In progress, we will wait for completion.
                 (Nothing, False, True) -> do
@@ -655,6 +666,8 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
             CbDone  _   -> do
               debugIO "request handled immediately (o), not queued." >> return result'
 
+        -- If an exception was received while waiting for IO to complete
+        -- we try to cancel the request here.
         let cancel e = do
                         debugIO $ "## Exception occurred. Cancelling request... "
                         debugIO $ show (e :: SomeException)
@@ -680,34 +693,34 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
                              delay <- runExpiredTimeouts mgr
                              registerAlertableWait delay num_remaining True
                         return $ IOFailed Nothing
-        let runner = do debugIO $ (dbg ":: waiting ") ++ " | "  ++ show lpol
+        let runner = do debugIO $ (dbgMsg ":: waiting ") ++ " | "  ++ show lpol
                         res <- readIOPort signal `catch` cancel
-                        debugIO $ dbg ":: signaled "
+                        debugIO $ dbgMsg ":: signaled "
                         case res of
                           IOFailed err -> FFI.throwWinErr fname (maybe 0 fromIntegral err)
                           _            -> return res
 
         -- Sometimes we shouldn't bother with the I/O manager as the call has
         -- failed or is done.
-        case execute of
+        case startCBResult of
           CbPending    -> runner
           CbDone rdata -> do
             free cdData
-            debugIO $ dbg $ ":: done " ++ show lpol ++ " - " ++ show rdata
+            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
-            debugIO $ dbg $ ":: done bytes: " ++ show bytes
+            debugIO $ dbgMsg $ ":: done bytes: " ++ show bytes
             case bytes of
-              Just res ->  free hs_lpol >> completionCB 0 res
+              Just res -> free hs_lpol >> completionCB 0 res
               Nothing  -> do err <- FFI.overlappedIOStatus lpol
                              numBytes <- FFI.overlappedIONumBytes lpol
                              -- TODO: Remap between STATUS_ and ERROR_ instead
                              -- of re-interpret here. But for now, don't care.
                              let err' = fromIntegral err
                              free hs_lpol
-                             debugIO $ dbg $ ":: done callback: " ++ show err' ++ " - " ++ show numBytes
+                             debugIO $ dbgMsg $ ":: done callback: " ++ show err' ++ " - " ++ show numBytes
                              completionCB err' (fromIntegral numBytes)
           CbError err  -> do
             free cdData
@@ -717,8 +730,10 @@ withOverlappedEx mgr fname h offset startCB completionCB = do
           _            -> do
             free cdData
             free hs_lpol
-            error "unexpected case in `execute'"
-      where spinWaitComplete fhndl lpol = do
+            error "unexpected case in `startCBResult'"
+      where dbgMsg s = s ++ " (" ++ show h ++ ":" ++ show offset ++ ")"
+            spinWaitComplete :: HANDLE -> Ptr FFI.OVERLAPPED -> IO (CbResult Int)
+            spinWaitComplete fhndl 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.
@@ -1028,7 +1043,7 @@ processCompletion Manager{..} n delay = do
           when (oldDataPtr /= nullPtr && oldDataPtr /= nullReq) $
             do debugIO $ "exchanged: " ++ show oldDataPtr
                payload <- peek oldDataPtr
-               let !(CompletionData _hwnd cb) = payload
+               let !cb = cdCallback payload
                free oldDataPtr
                reqs <- removeRequest
                debugIO $ "-1.. " ++ show reqs ++ " requests queued."
@@ -1089,19 +1104,10 @@ processRemoteCompletion = do
 
     -- 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`.
+    -- longer safe to use `entries` nor `completed` as they can now be modified
+    -- by the C thread.
     registerAlertableWait delay num_left False
 
-    debugIO "WinIOBlocked"
-    -- We may have been woken up due to a timer timeout.  So check for any
-    -- expired timeouts. If we have processed any completions only check
-    -- timeouts, if we have been woken up only to process timeouts then check if
-    -- we have to change the wait interval.
-    --
-    -- When not the threaded runtime we would not have reset the timer events
-    -- below.  Because of this when the request is done we have an additional
-    -- `step` here to reset the wait timers so the I/O manager doesn't keep
-    -- polling at the temporary high frequency we entered.
     debugIO "processRemoteCompletion :: done ()"
     return ()
 
@@ -1123,7 +1129,7 @@ io_mngr_loop _event mgr = go False
     where
       go maxDelay =
           do debugIO "io_mngr_loop:WinIORunning"
-             traceEventIO "io_mngr_loop:WinIORunning"
+             -- Step will process IO events, or block if none are outstanding.
              (more, delay) <- step maxDelay mgr
              let !use_max_delay = not (isJust delay || more)
              debugIO "I/O manager stepping."
@@ -1133,7 +1139,7 @@ io_mngr_loop _event mgr = go False
                  _ | event_id == io_MANAGER_WAKEUP -> return False
                  _ | event_id == io_MANAGER_DIE    -> return True
                  0 -> return False -- spurious wakeup
-                 _ -> do traceEventIO $ "handling console event: " ++ show (event_id `shiftR` 1)
+                 _ -> do debugIO $ "handling console event: " ++ show (event_id `shiftR` 1)
                          start_console_handler (event_id `shiftR` 1)
                          return False
 
@@ -1156,6 +1162,7 @@ io_MANAGER_DIE    = #{const IO_MANAGER_DIE}
 wakeupIOManager :: IO ()
 wakeupIOManager
   = do mngr <- 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)